perm filename GEN.SMI[SAI,TES] blob
sn#049731 filedate 1973-06-18 generic text, type T, neo UTF8
00100 COMMENT ⊗ VALID 00053 PAGES VERSION 16-2(96)
00200 RECORD PAGE DESCRIPTION
00300 00001 00001
00400 00006 00002 HISTORY
00500 00015 00003 LSTON (GEN)
00600 00023 00004 TABLEDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
00700 00028 00005 TABCONDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
00800 00031 00006 DSCR GENINI
00900 00035 00007 DSCR GETOP, GETADL, GETAD
01000 00037 00008 DSCR -- SAIL DECLARATION EXECS
01100 00042 00009 DSCR TYPSET, VALSET, XOWSET, etc.
01200 00045 00010 DSCR TCON, BTRU, BFAL, BNUL, BINF
01300 00048 00011 DSCR TWID10, ECHK, ESET
01400 00051 00012 DSCR DWN, BLOCK, BLNAME, ENTID, UP, NAMCHK, etc.
01500 00060 00013 ↑ENTID:
01600 00066 00014
01700 00074 00015 Check for match on block names.
01800 00077 00016 DSCR RQ00, RQSET, SRCSWT
01900 00080 00017
02000 00081 00018
02100 00084 00019 ↑SRCSWT:
02200 00085 00020 DSCR DFPREP, DCPREP, DWPREP, DFPINS, DFSET, DFENT, MACOFF
02300 00097 00021 DSCR STCAT
02400 00109 00022 DSCR LETSET, LETENT
02500 00111 00023 DSCR TWCOND,SWICHP,SWPOFF,PSWICH,OKEOF
02600 00119 00024
02700 00132 00025 SUBTTL EXECS for Entry Declaration
02800 00134 00026 DSCR ALOT
02900 00139 00027 ↑ALOT: ROUTINE TO HANDLE ALLOCATION
03000 00143 00028
03100 00147 00029 Comment
03200 00154 00030 NOSY: PUSHJ P,URGSTR IF ON STRING RING....
03300 00163 00031 LOADER BLOCK FOR POLISH FIXUP
03400 00165 00032 DSCR PDOUT
03500 00171 00033 DOLVIN: PUSH P,PNT2
03600 00173 00034 ROUTINE TO PUT OUT LOCAL VAR INFO -- USED BY DIS
03700 00178 00035 Allo -- Allocate One Type of Symbol
03800 00184 00036 ROUTINE TO ALLOCATE SPACE FOR TEMP CELLS AND TO OUTPUT
03900 00189 00037 REQINI -- USER REQUIRED INITIALIZTIONS
04000 00192 00038 DSCR DONES
04100 00194 00039
04200 00199 00040 NOGAG < BLOCK BITS USED BY "GOGOL", SO NO NEED
04300 00202 00041
04400 00206 00042
04500 00211 00043 MEMORY and LOCATION EXECS, ALSO UINCLL
04600 00214 00044 DSCR MAKBUK, FREBUK
04700 00216 00045 BEGIN ERRORS
04800 00221 00046 DSCR SCNBAK,POPBAK,KILPOP,QREM2,QTYPCK
04900 00226 00047 DSCR UNDEC -- Undeclared identifiers
05000 00233 00048 DSCR QDEC0,1,2 QARSUB QARDEC QPARM QPRDEC
05100 00240 00049 BEGIN SCOMM
05200 00243 00050 BEGIN INLINE
05300 00245 00051 DSCR CODNIT, WRDNIT, ONEWRD, SETSIX, SETOP, CODIND, CODREG, etc.
05400 00251 00052
05500 00256 00053 BEGIN COUNT
05600 00259 ENDMK
05700 ⊗;
00100 COMMENT ⊗HISTORY
00200 AUTHOR,REASON
00300 021 202000000140 ⊗;
00400
00500
00600 COMMENT ⊗
00700 VERSION 16-2(96) 1-9-73 BY RHT BUG #KT# TYPO IN UP
00800 VERSION 16-2(95) 1-9-73 BY RHT BUG #KY# ALLOW GLOBAL INTERNAL SYMBOLS TO GO OUT ALWAYS
00900 VERSION 16-2(94) 1-9-73 BY RHT BUG #KX# NEED ALLSTO BEFORE BEXIT
01000 VERSION 16-2(93) 1-8-73 BY JRL BUG KW DON'T ALLOW INTERNAL OR EXTERNAL ITEM DECLARATIONS
01100 VERSION 16-2(92) 1-8-73
01200 VERSION 16-2(91) 1-8-73
01300 VERSION 16-2(90) 12-13-72 BY HJS FIX RACE CONDITION WHERE MACROS AND CONDITIONAL COMPILATION END SIMULTANEOUSLY
01400 VERSION 16-2(89) 12-11-72 BY HJS ENDC PARSER SWITCH TRIGGER IN WHILEC, CASEC, FORC, AND FORLC BODIES
01500 VERSION 16-2(88) 12-2-72 BY HJS SAVE VALUE OF BITS DURING CONDITIONAL COMPILATION AND MACRO DEFINITION
01600 VERSION 16-2(87) 11-30-72 BY RHT ADD LIBTAB ENTRIES FOR POLLING
01700 VERSION 16-2(86) 11-28-72 BY RHT ADD CODE FOR CLEANUPS
01800 VERSION 16-2(85) 11-24-72 BY RHT BUG #KM# TYPO MESSED UP POLISH FIXUP FOR EXT PD
01900 VERSION 16-2(84) 11-21-72 BY JRL BAD JRST IN INMAIN
02000 VERSION 16-2(83) 11-20-72 BY KVL REMOVE ER51 - MEANINGLESS MSG. IF YOU WANT IT, SEE ME.
02100 VERSION 16-2(82) 11-19-72 BY HJS DLMPSH AND DLMPOP FOR PROPER HANDLING OF DEFINES WITHIN DEFINES
02200 VERSION 16-2(81) 11-17-72 BY RHT ADD CALL TO USER INITIALIZATION
02300 VERSION 16-2(80) 11-15-72 BY HJS INSERT DEFDLM QSTACK ROUTINES FOR DEFLUK BIT OF FF FOR COMPILE-TIME MACROS WITHIN MACROS
02400 VERSION 16-2(79) 11-15-72 BY KVL SURPRESS CODE GENERATION AFTER SERIOUS ERRORS.
02500 VERSION 16-2(78) 11-10-72 BY HJS ADD DLMSTG STACK SO MACROS DEFINED WITHIN MACROS WITH CONCATENATION WILL WORK
02600 VERSION 16-2(77) 11-10-72 BY JRL ADD ERR MSG FOR PROPS AND LIBTAB ENTRIES
02700 VERSION 16-2(76) 11-8-72 BY HJS IMPLEMENTATION OF CHECK_TYPE
02800 VERSION 16-2(75) 11-7-72 BY JRL GIVE ERROR MESSAGE BAD USE OF BIND
02900 VERSION 16-2(74) 11-2-72 BY RHT BUG #JY# TYPE CHECKING ON MEMORY INDEX
03000 VERSION 16-2(73) 11-2-72 BY JRL ADD MAINPR TO LIBTAB
03100 VERSION 16-2(72) 10-24-72 BY JRL ADD INMAIN EXEC TO INIT MAINPR
03200 VERSION 16-2(71) 10-22-72 BY RHT BUG #JU# FIX UP ACKTAB ENCLOBERMENT BY QUICK_CODE
03300 VERSION 16-2(70) 10-20-72 BY RHT BUG #JV# MEMORY TRIED TO USE AC 0 AS INDEX
03400 VERSION 16-2(69) 10-20-72 BY RHT PROVIDE EXTRA ENTRY POINTS IN REQINI
03500 VERSION 16-2(68) 10-17-72 BY AM HJS IMPLEMENTATION OF DECLARATION FEATURE FOR TYPE CHECKING AT COMPILE TIME
03600 VERSION 16-2(67) 10-12-72 BY HJS BUG #JP# AND CVMS IMPLEMENTATION
03700 VERSION 16-2(66) 10-10-72 BY KVL FIX ; ELSE RECOVERY
03800 VERSION 16-2(65) 10-5-72 BY JRL PREPARE FOR EXPO
03900 VERSION 16-2(64) 10-5-72 BY KVL MAKE UNDECLARED IDENTIFIERS AN ERR.
04000 VERSION 16-2(63) 9-29-72 BY RHT BUG #JH# FIX TYPO IN REQINI
04100 VERSION 16-2(62) 9-27-72 BY HJS FORCE EXECUTION OF BLOCK WHEN A DEFINE IS THE ONLY DECLARATION IN THE BEGINNING OF A BLOCK.
04200 VERSION 16-2(61) 9-27-72 BY RHT BUG #JF# MESSAGE PROC LINK GETTING WRONG ADDRESS
04300 VERSION 16-2(60) 9-27-72 BY JRL ADD ARYSET,SAFSET EXECS FOR DATUMS
04400 VERSION 16-2(59) 9-25-72 BY RHT BUG #IZ# GLOBAL STUFF SHOULD STAY OUT OF PD
04500 VERSION 16-2(58) 9-22-72 BY RHT BUG #IV# UNDEC FWRD MESSAGE PROC PD BUG
04600 VERSION 16-2(57) 9-21-72 BY RHT MAKE THE LOCN PUT THING INCOR
04700 VERSION 16-2(56) 8-24-72 BY RHT ADD CAUSE & INTERROGATE TO XCALL TABLE
04800 VERSION 16-2(55) 8-23-72 BY JRL ADD BEXIT CODE FOR CONTEXT
04900 VERSION 16-2(54) 8-22-72 BY RHT PREVENT DOUBLE ALLOCATION OF KILL SET
05000 VERSION 16-2(53) 8-18-72 BY JRL CHANGE TYPPRO TO HANDLE MATCHING PROCEDURES
05100 VERSION 16-2(52) 8-14-72 BY RHT EXEC FOR LOCATION(X)
05200 VERSION 16-2(51) 8-14-72 BY RHT EVAL →→ APPLY
05300 VERSION 16-2(50) 8-14-72 BY RHT ADD EXECS FOR MEMORY
05400 VERSION 16-2(49) 8-11-72 BY RHT MAKE POLISH FIXUP TO GET AT EXTERNAL PD'S
05500 VERSION 16-2(48) 8-11-72 BY JRL ADD REMEMBER ETC TO LIBTAB
05600 VERSION 16-2(47) 8-4-72 BY RHT BUG #IT# EXTERNALS IN THE PD
05700 VERSION 16-2(46) 8-1-72 BY RHT MAKE KILL SETS REAL SETS
05800 VERSION 16-2(45) 7-28-72 BY RHT CHANGE FORKER TO SPROUT
05900 VERSION 16-2(44) 7-26-72 BY HJS TURN OFF MACRO EXPANSION WHEN SCANNING FORMAL PARAMETERS.
06000 VERSION 16-2(43) 7-25-72 BY RHT FIX THE PD SYMBOL
06100 VERSION 16-2(42) 7-24-72 BY RHT PUT FORKER IN LIST OF XCALLED FNS
06200 VERSION 16-2(41) 7-24-72 BY RHT PUT OUT SYMBOL FOR PD
06300 VERSION 16-2(40) 7-22-72 BY RHT ADD KILL LISTS
06400 VERSION 16-2(39) 7-9-72 BY RHT NO PD IF NO DADDY
06500 VERSION 16-2(38) 7-5-72 BY DCS BUG #II# DON'T LET DEFINES OUT AS SYMBOLS
06600 VERSION 16-2(37) 7-2-72 BY JRL SET LEAPIS IF ANY LEAP FUNCTIONS USED
06700 VERSION 16-2(36) 6-25-72 BY DCS BUG #HX# PARAMETERIZE OPCODE FILE NAMES (AND OTHERS)
06800 VERSION 16-2(35) 6-21-72 BY RHT CHANGE WAY PDA,,0 SEMBLK IS LINKED
06900 VERSION 16-2(34) 6-14-72 BY JRL BUG ##H#S# STRING ITEMVAR PROCS ARE NOT STRING PROCS.
07000 VERSION 16-2(32) 6-8-72 BY RHT MAKE ENTRY IN LIBTAB FOR EVAL
07100 VERSION 16-2(31) 5-16-72 BY RHT GIVE ERR IF SIMPLE PROC ALLOCATES
07200 VERSION 16-2(30) 5-16-72 BY RHT TO HANDLE OWN VARS IN BLOCKS--ENTID
07300 VERSION 16-2(29) 5-14-72 BY DCS BUG #HH# BETTER INITIAL CODE IF /H
07400 VERSION 15-6(7-28) 4-20-72 LOTS OF THINGS
07500 VERSION 15-2(6) 2-21-72 BY HJS THE BRAVE NEW PARSER WORLD
07600 VERSION 15-2(5) 2-6-72 BY DCS BUG #GN# UUOS TO START_CODE TABLE, FIX BOUNDARY COND.
07700 VERSION 15-2(4) 2-5-72 BY DCS BUG #GJ# ADD LSTON LISTING CONTROL STUFF
07800 VERSION 15-2(3) 2-5-72 BY DCS BUG #GI# ADD CAT ROUTS TO LIBFSN (CHRCAT, ETC.)
07900 VERSION 15-2(2) 2-1-72 BY DCS ISSUE NEW STYLE %ALLOC SPACE REQUESTS
08000 VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
08100
08200 ⊗;
00100 LSTON (GEN)
00200 BITD2DATA (EMITTER)
00300
00400 ; EMITTER BITS -- PUT DESCRIPTORS IN POSITION TO BE EXAMINED BY $L OPERATIONS
00500
00600 ↑GENBTS:
00700 BIT (NOUSAC,400000) ;DON'T USE D(RH) AS AC #
00800 BIT (USCOND,200000) ;USE C(RH) AS 3 BITS OF CONDITION
00900 BIT (USADDR,100000) ;USE C(LH) AS DISPLACEMENT PART
01000 BIT (USX , 40000) ;USE D(LH) AS INDEX REG
01100 BIT (NORLC , 20000) ;RELOCATE NOT!
01200 BIT (IMMOVE, 10000) ;IF OPERAND CONSTANT, LOAD IT ANY WAY POSSIBLE
01300 BIT (INDRCT, 4000) ;INDIRECT ADDRESSING REQUIRED
01400 BIT (JSFIX , 2000) ;JUST DO A FIXUP (DON'T GET SEMANTICS).
01500 BIT (NOADDR, 1000) ;NO EFFECTIVE ADDRESS PART
01600 BIT (EMADDR,400) ;WE WANT THE ADDRESS OF THIS ENTITY
01700 BIT (PNTROP, 200) ;INTERNAL OPERATION INDICATING POINTER INDEXING
01800 BIT (FXTWO, 100) ;USE SECOND FIXUP WORD
01900 BLOCK 6 ;LEFT OVER BITS
02000
02100
02200 BITD2DATA (GENMOV)
02300
02400 ;CONTROL BITS PASSED TO GENMOV IN THE RIGHT HALF OF "FF".
02500 ;FOR COMMENTS, SEE THE FILE "TOTAL".
02600
02700
02800 BIT (INSIST,400000) ;INSIST ON DOING TYPE CONVERSION.
02900 ;THE RIGHT HALF OF "B" CONTAINS TYPE BITS.
03000 BIT (ARITH,200000) ;INSIST ARGUMENT IS AN ARITHMETIC TYPE.
03100 BIT (EXCHIN,100000) ;DO AN EXCHOP ON THE WAY INTO THE ROUTINE.
03200 BIT (EXCHOUT,40000) ;DO AN EXCHOP ON THE WAY OUT OF A ROUTINE.
03300 BIT (GETD,20000) ;DO A GETAD BEFORE DOING THIS ROUTINE.
03400 BIT (SPARE,10000) ;NEGAT←← 10000 ;GET THE OPERAND IN NEGATIVE FORM.
03500 BIT (POSIT,4000) ;INSIST ON THE OPERAND IN POSITIVE FORM.
03600 BIT (BITS2,2000) ;UPDATE SBITS2 FROM $SBITS2(PNT2) ON WAY OUT.
03700 BIT (MRK,1000) ;MARK THE ACCUMULATOR MENTIONED IN D WITH THE ARGUMENT.
03800 ;(DONE AT END OF MAIN OPERATION)
03900 ;THIS MEANS "GENERATE A TEMP CELL IF NECESSARY."
04000 BIT (ADDR,400) ;SAME BIT AS GENERATOR USES. USE THE ADDRESS OF ARG.
04100 BIT (REM,200) ;REMOP ON THE WAY OUT.
04200 BIT (NONSTD,100) ;NON-STANDARD OPERATION.
04300 BIT (SPAC,40) ;WE HAVE A SPECIFIC AC NUMBER IN MIND.
04400 BIT (PROTECT,20) ;PROTECT THIS ACCUMULATOR.
04500 BIT (UNPROTECT,10) ;UNPROTECT THIS ACCUMULATOR.
04600 BIT (DBL,2) ;NEED A DOUBLE ACCUMULATOR.
04700 BIT (INDX,1) ;NEED AN INDEXABLE ACCUMULATOR.
04800
04900
05000 BITDATA (STROP)
05100
05200 ; BITS TO BE PASSED TO STROP IN A
05300 ; SEE STROP FOR MEANINGS OF THESE BITS.
05400
05500 ↓BPWORD ←← 400000
05600 ↓LNWORD ←← 200000
05700 ↓BPFIRST ←← 100000
05800 ↓ADOP ←← 40000
05900 ↓SBOP ←← 20000
06000 ↓UNDO ←← 10000
06100 ↓STAK ←← 4000
06200 ↓BPINC ←← 2000
06300
06400 ZERODATA (EXEC ROUTINES -- GLOBAL VARIABLES)
06500
06600 COMMENT ⊗
06700 ADEPTH -- Whenever code is generated to push something onto the
06800 System stack (P, usually 17), currently only when an actual
06900 parameter is put on, this is incremented. It is added to
07000 the displacement for a formal parameter whenever it is ref-
07100 erenced. This allows the access code to get to the right
07200 stack element for a parameter, no matter what's on the stack.
07300 ADEPTH is decremented when things come off. It is restarted
07400 whenever a procedure declaration is encountered (first checked,
07500 since it should always be 0 at that point).
07600 ⊗
07700 ↓ADEPTH: 0
07800
07900 ;APARNO -- a count of the number of non-string parameters in
08000 ; the current procedure -- used to set up the $NPRMS word
08100 ; in the 2d Semblk for the procedure
08200 ↓APARNO: 0
08300
08400 ;DEFRN1 -- Semantics of first formal macro param in VARB-Ring
08500 ; while scanning macro params. Used to release all the
08600 ; Semblks for these params when done with them.
08700 ↓DEFRN1: 0
08800
08900 COMMENT ⊗
09000 FALLOC -- Semantics of a [0] integer constant, created the
09100 first time the word FALSE appears in source -- FALSE
09200 thenceforth equated to this [0] constant, since the two
09300 are internally equivalent -- see BFAL routine
09400 ⊗
09500 ↓FALLOC: 0
09600
09700 ;GLOBCNT -- used in ENTID to count # global items declared
09800 ↓GLOBCNT: 0
09900
10000 ;LENCNT -- AOS'ed whenever substring operation is begun, SOS'ed
10100 ; when it is complete. BINF (∞≡length(str) EXEC) checks
10200 ; this to make sure there's a string to take the length of.
10300 ↓LENCNT: 0
10400
10500 ;LENSTR -- QSTACK descriptor -- each entry is Semantics of a
10600 ; string being SUBSTRd. Kept here for convenience of BINF,
10700 ; so that it doesn't have to search up the stack for it.
10800 ↓LENSTR: 0
10900
11000 ;NULLOC -- Semantics of "", for BNUL (NULL ≡ "" EXEC)
11100 ↓NULLOC: 0 ;SEE FALLOC, TRULOC
11200
11300 ;OPCODE -- for binary operations, proper opcode (and control bits),
11400 ; fetched from one of the OP tables (PMTAB, TDTAB, MXMNTB) via the
11500 ; class code in the production which called the EXEC. Used as tem-
11600 ; plate for output instruction. Stored in OPCODE for convenience
11700 ↓OPCODE: 0
11800
11900 ;SDEPTH -- ADEPTH-type count for String stack -- bumped not only for
12000 ; actual params, but also for String Procedure results, other
12100 ; String operations which use the stack.
12200 ↓SDEPTH: 0
12300
12400 ;SPARNO -- APARNO-type count of String formals -- it's possible that
12500 ; this is doubled before use, since there are two words for each
12600 ; String descriptor. See PROCED, ENTID for uses.
12700 ↓SPARNO: 0
12800
12900 ;THISE -- Set by ECHK EXEC, remembers type of expression, since two
13000 ; class codes are passed in from PARSER
13100 ; (e.g., EXEC @E ECHK @class randomexec)
13200 ↓THISE: 0
13300
13400 ;TRULOC -- Semantics of [-1], used by BTRU (TRUE≡≠0 EXEC)
13500 ↓TRULOC: 0
13600
13700
00100 TABLEDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
00200 NOGAG <
00300 COMMENT ⊗
00400 LIBTAB -- table of fixups (current ends of chains) for routines
00500 called by SAIL programs to accomplish complicated operators
00600 (CAT, SUBSTR, ARRMAK, etc.) -- the LIBFSN macro, with the
00700 appropriate definition of the FN macro, puts out a symbolic
00800 index into this table for each name mentioned (R&ROUTNAME),
00900 and a word of table to hold the fixup. It is used again below
01000 (LIBNAM) to create a table of corresponding External RADIX50
01100 request words which will be used in DONES to put out the chain
01200 requests. The XCALL and LPCALL macros are used to put out
01300 (fixup chained) calls to these routines.
01400 ⊗
01500 DEFINE LIBFSN <
01600 FN <CAT> ;STRING CONCATENATIONS.
01700 FN <CHRCAT> ;INTEGER&STRING
01800 FN <CATCHR> ;STRING&INTEGR
01900 FN <CHRCHR> ;INTEGR&INTEGR
02000 FN <CAT.RV> ;STRING&STRING, 2D ARG FIRST
02100 FN <SUBSR> ;SUBSTRING (FOR)
02200 FN <SUBST> ;SUBSTRING (TO)
02300 ; FN <SUBSI> ;EXTINCT (USED TO BE SUBSTRING INF)
02400 FN <GETCH> ;CONVERT FIRST CHAR OF STRING TO INTEGER
02500 FN <PUTCH> ;CONVERT LOW ORDER 7 BITS TO STRING
02600 FN <POW> ;EXPONENTIATION
02700 FN <FPOW> ;FLOATING ARG, INTEGER EXPONENT.
02800 FN <LOGS> ;INTEGER ARG,FLOATING EXPONENT.
02900 FN <FLOGS> ;FLOATING ARG, FLOATING EXPONENT.
03000 FN <ARMRK> ;MARK THE ARRAY PUSHDOWN STACK.
03100 FN <ARMAK> ;MAKE AN ARRAY (PARAMS IN STACK)
03200 FN <ARREL> ;RELEASE ARRAYS BACK TO LAST MARK ON STACK.
03300 LEP <
03400 FN <LEAP> ;CALL LEAP!
03500 FN <DATM> ;THIS IS REFERENCE TO A WORD WHICH IS XWD 3,→
03600 ; BASE OF DATUM TABLE.
03700 FN <LPRYER> ;DATUM(X) WAS NULL, WHEN AN ARRAY WAS EXPECTED.
03800 FN <PROPS> ;THE PROPS BYTE POINTER POINT 9,INFOTAB(3),35
03900 GLOC <
04000 FN <GPROPS> ;GLOBAL PROPS
04100 FN <GDATM> ;GLOBAL DATUM
04200 FN <.MES1>
04300 FN <.MES2>
04400 FN <DATERR>
04500 >;GLOC
04600 FN <PITBND> ;BIND PD TO ITEM
04700 FN <PITCOP> ;COPY PROC ITEM
04800 FN <PITDTM> ;-1(P)←DATUM(-1(P))
04900 FN <APPLY> ;INTERP CALLER
05000 FN <SPROUT> ;SPROUTER
05100 FN <CAUSE> ;CAUSES EVENTS
05200 FN <INTERROGATE> ;INTERROGATE FUNCTION
05300 FN <MAINPR> ;INITIALIZE PROCESSES
05400 >;LEP
05500 DIS <
05600 FN <BEXIT> ;BLOCK EXITER
05700 FN <STKUWD> ;STACK UNWINDER
05800 >;DIS
05900 FN <CSERR> ;CASE STATEMENT INDEX OUT OF BOUNDS
06000 FN <ALLRM> ;REMEMBER ALL
06100 FN <ALLFOR> ;FORGET ALL
06200 FN <ALLRS> ;RESTORE ALL
06300 FN <REMEMB> ;REMEMBER
06400 FN <FORGET> ;FORGET
06500 FN <RESTOR> ;RESTORE
06600 FN <.SUCCE> ;SUCCEED (FOR MATCH. PROCS)
06700 FN <.FAIL> ;FAIL
06800 FN <.UINIT> ;USER INITIALIZATIONS
06900 FN <DDFINT> ;DO DEFERED INTERRUPT
07000 FN <INTRPT> ;SET ≠0 WHEN HAVE AN INTERRUPT
07100 >
07200
07300 DEFINE FN '(X) <
07400 ↓R'X ←← LIBNUM
07500 ↓LIBNUM ←← LIBNUM+1
07600 0 ;FIXUP WORD.
07700 >
07800
07900 ↓LIBNUM←←0
08000
08100 ↓LIBTAB: LIBFSN ;FIXUPS FOR LIBRARY FUNCTIONS.
08200 >;NOGAG
08300 ; the current procedure -- used to set up the $NPRMS word
08400
00100 TABCONDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
00200
00300 NOGAG <
00400 COMMENT ⊗
00500 LIBNAM -- these are the external request symbols for the
00600 above-mentioned runtime routines -- see LIBTAB, above
00700 ⊗
00800
00900 DEFINE FN (X) < RADIX50 60,X >
01000
01100 LIBNAM: LIBFSN
01200 >
01300
01400 COMMENT ⊗
01500 TYPTAB, VALTAB, XOTAB
01600 These tables are used by the TYPSET, VALSET, XOWSET routines
01700 to convert the class codes from the PARSER, specifying which
01800 data type, REFERENCE or VALUE type, or modifier (SAFE, etc.)
01900 is being requested, to the appropriate TBITS bit. These three
02000 routines are, as might be guessed, EXEC routines.
02100 ⊗
02200
02300 ↑TYPTAB:
02400 HELITM: ITEM ;ITEM
02500 HELITV: ITMVAR ;ITEMVAR
02600 0+SET ;SET
02700 LABEL+FORWRD ;LABEL
02800 FLOTNG ;REAL
02900 INTEGR ;INTEGER
03000 STRING ;STRING
03100 INTEGR ;BOOLEAN
03200 0+SET+LSTBIT ;LIST
03300 XWD SAFE,SET!INTEGR ;KILL_SET
03400 0+SET!FLOTNG ;CONTEXT
03500 XOTAB: XWD INTRNL,0 ;INTERNAL
03600 XWD SAFE,0 ;SAFE
03700 XWD EXTRNL,0 ;EXTERNAL
03800 XWD OWN,0 ;OWN
03900 XWD RECURS,0 ;RECURSIVE
04000 XWD EXTRNL,FORTRAN ;FORTRAN
04100 FORWRD ;FORWARD
04200 SHORT ;SHORT
04300 XWD SIMPLE,0 ;SIMPLE
04400 XWD MPBIND,INTEGR ;MATCHING
04500 GLOC <
04600 GLOBL ;GLOBAL LEAP TYPE.
04700 XWD MESSAGE,0 ;MESSAGE
04800 >;GLOC
04900
05000 VALTAB: XWD REFRNC,0 ;REFERENCE
05100 XWD VALUE,0 ;VALUE
05200 XWD VALUE!MPBIND,ITMVAR ;? PARAMETER
05300
05400 CHKTAB: XWD RES,0 ; RESERVED
05500 XWD BILTIN,0 ; BUILTIN FUNCTION
05600 LEP<
05700 LPARRAY ; LEAP ARRAY
05800 >;LEP
05900
06000 XWD SBSCRP,0 ; NORMAL ARRAY
06100 XWD DEFINE,0 ; DEFINE
06200 PROCED ; PROCEDURE
06300
06400 ENDDATA
06500 SUBTTL EXEC (GENERATOR) INITIALIZATION
06600
06700
00100 DSCR GENINI
00200 CAL PUSHJ from SAIL Exec
00300 RES Initializes variables for whom the EXECS (generators)
00400 have main responsibility. Calls RELINI and LEPINI to set
00500 up Relfile and Leap variables
00600 SEE SAIL Exec, RELINI, LEPINI
00700 ⊗
00800 ↑GENINI:
00900 NOGAG <
01000 IFN PATSW,<II←←4;>II←←3
01100 DIS <II←←10> ;LONGER STARTUP
01200 ;* * * * * *
01300 REN <
01400 SETOM INHIGH ;WILL BE IN HIGH FIRST IF HISW
01500 MOVEI TEMP,1
01600 MOVEM TEMP,HCNT ;DATA STARTS AT 1 IF HISW
01700 >;REN
01800 MOVEI TEMP,II ;START HERE
01900 REN <
02000 SKIPE HISW ;TWO-SEGMENT COMPILATION?
02100 MOVEI TEMP,400000+II ;YES, CODE STARTS HERE
02200 >;REN
02300 MOVEM TEMP,PCNT
02400 ;;#HH# 5-14-72 DCS (2-2) ACCOUNT FOR UPPER SEGMENT CODE
02500 REN <
02600 MOVEI TEMP,5-II(TEMP) ;NOW ADJUST INITIAL PD PUSH DATA
02700 HRRM TEMP,IPDFIX ;SEE SAIL FOR THIS ARCHBLOCK
02800 >;REN
02900 ;;#HH# (2-2)
03000 >;NOGAG
03100 NODIS <
03200 Comment ⊗ The first four words of code (for main programs anyway)
03300 are:
03400
03500 0 SKIPA ;NON RPG-MODE START
03600 1 SETOM RPGSW ;RPG-MODE START
03700 2 JSR SAILOR ;CALL INITIALIZER
03800 3 AOS "PAT" ;OUTER BLOCK AOS
03900
04000 Non main programs have these four words present (in some partially completed
04100 state), so that PCNT still starts at 4.
04200
04300 ⊗
04400 >;NODIS
04500
04600 DIS <
04700 Comment ⊗ The first words of code are (for main programs)
04800
04900 0 SKIPA ;NON-RPGMODE START
05000 1 SETOM RPGSW ;RPG MODE
05100 2 JSR SAILOR ;INITIALIZE
05200 3 HRLOI RF,1 ;FOR FAKE F LINK
05300 4 PUSH P,RF
05400 5 PUSH P,[PDA,,0] ;PDA OF OUTER BLOCK & USELESS STATIC LINK
05500 6 PUSH P,SP ;REST OF MSCP
05600 7 HRRZI RF,-2(P) ;POINT THERE
05700
05800 ⊗;
05900 >;DIS
06000
06100 ; MARK TOP AC'S UNUSABLE FOR GENERAL ALLOCATION
06200
06300 FOR II⊂(RSP,RP,USER,TEMP,LPSA,RF) <
06400 SETOM ACKTAB+II>
06500
06600 ; ***** THIS CODE MOVED TO RELOUTPUT AREA IN TOTAL
06700 PUSHJ P,RELINI ;INITIALIZE LOADER FILE VAIRIABLES
06800 ; *****
06900
07000
07100 IFN FTDEBUG <
07200 MOVE TEMP,BITABLE
07300 EXTERNAL $M
07400 MOVEM TEMP,$M+3 ;RAID LOC
07500 >
07600
07700 ; ***** THIS CODE MOVED TO LEAP
07800 LEP <
07900 PUSHJ P,LEPINI ;INITIALIZE LEAP VARIABLES
08000 >;LEP
08100 ; ******
08200 POPJ P,
08300
08400 REN <
08500 DSCR HISET, LOSET, SWIT -- Call to Get Correct PCs into PCNT and HCNT
08600 DES Calling HISET makes sure code will go to upper segment.
08700 Calling LOSET makes sure it will go to lower segment
08800 Calling SWIT does HISET if LOSET was last, LOSET if HISET was last.
08900 ⊗
09000 ↑HISET: SKIPE INHIGH ;ALREADY IN HIGH SEGMENT?
09100 POPJ P, ;YES, DONE
09200 JRST SWIT ;NO, GO IN
09300 ↑LOSET: SKIPE INHIGH ;ALREADY IN LOW SEGMENT OR
09400 ↑SWIT: SKIPN HISW ; IS THIS RELEVANT?
09500 POPJ P, ;YES OR NO
09600 SETCMM INHIGH ;IF IN, NOW OUT AND VICE VERSA
09700 PUSHJ P,FRBT ;FORCE OUT BINARY IN OTHER SEGMENT
09800 MOVE TEMP,PCNT ;EXCHANGE PCS
09900 EXCH TEMP,HCNT
10000 MOVEM TEMP,PCNT
10100 POPJ P, ;DONE
10200 >;REN
10300
00100 DSCR GETOP, GETADL, GETAD
00200 DES Routines to pick things up from symbol table blocks.
00300 GETOP is the entry which also picks up the
00400 generator stack entry specified by accumulator A.
00500 ⊗
00600
00700
00800 ↑GETAD2: SKIPN PNT2
00900 ERR <DRYROT -- GETAD>
01000 MOVE SBITS2,$SBITS(PNT2)
01100 MOVE TBITS2,$TBITS(PNT2)
01200 POPJ P,
01300
01400
01500
01600 ↑GETAD: JUMPN PNT,GETSTF ;TEST FOR NULL SEMANTICS.
01700 ERR <DRYROT -- GETAD>
01800 ↑GETADL: SKIPN PNT,LPSA ;MAKE SURE WE HAVE A GOOD ENTRY
01900 ERR <DRYROT -- GETAD>
02000 GETSTF: MOVE SBITS,$SBITS(PNT)
02100 MOVE TBITS,$TBITS(PNT) ;BOTH BITS WORDS
02200 POPJ P,
02300
02400
02500
02600
02700
02800
02900
03000
03100
03200
03300 BEGIN GENDEC
03400 SUBTTL EXECS for typing variables, equating TRUE with -1, etc.
03500
03600
00100 DSCR -- SAIL DECLARATION EXECS
00200 DES These are the declarations routines.
00300 They take care of simple identifier declarations
00400 as well as procedures, arrays, etc. If a "BEGIN"
00500 is seen, the varb structure recurrs out of the current
00600 block, a new one is created, the VARB list is updated to the
00700 new block, and a new symbol table bucket is made.
00800 The reverse is effected when an "END" is seen which
00900 matches a BEGIN which involved declarations.
01000
01100 For procedures, a similar thing happens.
01200 ⊗
01300
01400 DSCR TYPDEC, TYPAR, TYPPRO, etc.
01500 PRO TYPDEC TYPAR TYPPRO TYPR1 PRST
01600 DES The routines to "type" an entity and return an appropriate
01700 parser token. Thus, the parser can be aware of the types of
01800 user identifiers. This speeds up operations somewhat, and means
01900 that the parser can do much of the "semantic" type-checking.
02000 ⊗
02100
02200 ↑TYPDEC: HRLI A,CLSIDX ;ALL VARIABLES ARE CLASS MEMBERS
02300 TLNE TBITS,CNST ;a constant ?
02400 JRST MYCON
02500 TLNE TBITS,SBSCRP ;ARRAY?
02600 JRST ARLO ;YES
02700 TRNE TBITS,ITEM+ITMVAR+PROCED
02800 JRST TYPDES ;DESCRIMINATE
02900 HRRI A,TICTXT
03000 TRNE TBITS,FLOTNG
03100 TRNN TBITS,SET
03200 CAIA
03300 POPJ P,
03400 HRRI A,TIST ;SET
03500 TRNE TBITS,SET
03600 POPJ P,
03700 HRRI A,TIVB
03800 TRNE TBITS,INTEGR+FLOTNG+DBLPRC
03900 POPJ P,
04000 HRRI A,TISV ;STRING VARIABLE
04100 TRNE TBITS,STRING
04200 POPJ P,
04300 HRRI A,TILB ;LABEL
04400 TRNE TBITS,LABEL
04500 POPJ P,
04600 TROUBL: HRRI A,TI ;UNDECLARED IDENTIFIER
04700 POPJ P,
04800
04900 TYPDES: HRRI A,TIPR ;PROCEDURE
05000 TRNE TBITS,PROCED
05100 POPJ P,
05200 HRRI A,TIIT ;ITEM
05300 TRNE TBITS,ITEM
05400 POPJ P,
05500 HRRI A,TITV ;ITEMVAR
05600 TRNE TBITS,ITMVAR
05700 POPJ P,
05800 JRST TROUBL
05900
06000 ARLO: HRRI A,TIAR ;ARITHMETIC OR ITEM ARRAY.
06100 POPJ P, ;ARITHMETIC OR ITEM ARRAY
06200
06300 MYCON: HRRI A,TICN ;ARITHMETIC CONTSTANT
06400 TRNE TBITS,STRING ;MIGHT BE STRING
06500 HRRI A,TSTC ;STRING CONSTANT.
06600 POPJ P,
06700
06800 ↑TYPAR: ;TYPE AN ARRAY
06900 ↑TYPPRO: TDZA B,B ;INDEX INTO GENRIG,PARIG
07000 ↑TYPR1: MOVEI B,1
07100 SKIPN LPSA,GENRIG(B) ;SEMANTICS
07200 ERR <UNTYPED PROCEDURE AS EXPRESSION>,1,<[TRO TBITS,INTEGR
07300 JRST TYPESS]>
07400 TYA1: PUSHJ P,GETADL ;GET GOOD BITS
07500 TLNE TBITS,MPBIND ;MATCHING PROCEDURE
07600 TLNN FF,LPPROG ;AND FOREACH IN PROGRESS
07700 CAIA
07800 POPJ P,
07900 TRZ TBITS,PROCED ;TURN OFF PROCEDURE
08000 TLZ TBITS,-1
08100 TRNN TBITS,ALTYPS ;ANYTHING THERE?
08200 TYPER: JRST [HRLI A,CLSIDX ;WE FAKE AN INTEGER
08300 HRRI A,TIVB
08400 JRST TYPESS]
08500 PUSHJ P,TYPDEC ;TYPE BIT
08600 TYPESS: MOVEM A,PARRIG(B) ;PUT DOWN THE ANSWER
08700 POPJ P,
08800
08900
09000 ↑PRST: SKIPN PNT,GENRIG
09100 POPJ P, ;PROCEDURE WAS UNTYPED....
09200 MOVE TBITS,$TBITS(PNT) ; TYPE.
09300 ;;#HS# JRL 6-14-72 A STRING ITEMVAR IS NOT A STRING
09400 TRNE TBITS,ITMVAR!ITEM
09500 JRST REMOP
09600 ;;#HS#
09700 TRNE TBITS,STRING ;IF OF TYPE STRING, COMPLAIN.
09800 JRST SUBIT ;DOWN IN TOTAL -- SUBTRACTS FROM STACK.
09900 JRST REMOP
10000
00100 DSCR TYPSET, VALSET, XOWSET, etc.
00200 PRO TYPSET XOWSET VALSET HELAR2 HELAR1 HELARY CLRSET PRSET
00300 DES EXECS to collect type bits as they are specified
00400 The standard mechanisms for entering variables.
00500 Little routines are called to turn on the right bits
00600 in the "BITS" word for ENTERS to eventually use
00700 ⊗
00800
00900
01000
01100 ;RECORD ANY MODIFIERS ON THE DECLARATIONS.
01200 ;CALLED WITH CLASS INDEX TYPE IN REGISTER B.
01300 ↑XOWSET: SKIPA A,XOTAB(B) ;PICK UP TABLE ENTRY
01400 ↑VALSET: MOVE A,VALTAB(B) ;INDEXED BY "B" PASSED FROM PARSER
01500 IORM A,BITS
01600 POPJ P, ;RETURN
01700
01800 LEP<
01900 ↑ARYSET: SKIPA A,[LPARRAY]
02000 ↑SAFSET: MOVEI A,SAFE ;SAFE BIT
02100 IORM A,BITS ;SAVE IT
02200 POPJ P,
02300 >;LEP
02400 ↑HELAR2: MOVE B,BITS
02500 PUSHJ P,HELSPC ;SPECIAL FOR ARRAY ITEMS.
02600 TDZA B,B ;ITEM .......
02700 ↑HELAR1: MOVEI B,1
02800 ↑HELARY: MOVEI A,LPARRAY ;SAY A LEAP TYPE ARRAY.
02900 IORM A,BITS ;AND FALL THROUGH TO TYPE IT.
03000 ↑HELSET:
03100 ↑TYPSET: MOVE A,TYPTAB(B) ;ORDINARY TYPES.
03200 IORB A,BITS
03300 MOVEM A,ARYBIT ;AND RECORD SHOULD AN ARRAY BE DECLARED.
03400 POPJ P,
03500
03600 ↑CLRSET: SETZM BITS ;ZERO FOR A NEW TYPE
03700 POPJ P,
03800
03900 ↑PRSET: MOVEI A,PROCED
04000 IORM A,BITS
04100 POPJ P,
04200
04300 ; ******
04400 ; STARY, ENTARY, Array declaration routines, were moved to ARRAY code
04500 ; ****** 11/24/70
04600 MOVEM A,PARRIG(B) ;PUT DOWN THE ANSWER
04700
00100 DSCR TCON, BTRU, BFAL, BNUL, BINF
00200 PRO TCON
00300 DES kludges to make TRUE, FALSE, NULL, and ∞ work right
00400 TRUE≡-1, so a constant is created (once), and Semantics rtnd
00500 FALSE≡0
00600 NULL≡""
00700 ∞≡LENGTH(innermost String being SUBSCRd -- else error)
00800 ⊗
00900
01000 ↑TCON: JRST .+1(B) ;CALL CORRECT ROUTINE.
01100 JRST BINF ;∞ OPERATOR.
01200 JRST BNUL ;NULL
01300
01400 ↑BTRU: SKIPA C,[XWD -1,TRULOC]
01500 ↑BFAL: MOVEI C,FALLOC
01600 PUSHJ P,GETITC ;GET THE CONSTANT.
01700 RETRT: MOVEM PNT,GENRIG
01800 POPJ P,
01900
02000 ↑BTRU1: HRROI C,TRULOC ;FOR TRUE
02100 GETITC: SKIPE PNT,(C) ;IS THERE A VALUE ALREADY??
02200 POPJ P, ;YES -- RETURN IT.
02300 PUSH P,BITS
02400 HLRE A,C ;THIS IS 0 OR -1
02500 PUSHJ P,CREINT
02600 MOVEM PNT,(C)
02700 POP P,BITS ;RESTORE
02800 POPJ P,
02900
03000
03100
03200 ↑BNUL: SKIPE PNT,NULLOC
03300 JRST RETRT
03400 PUSH P,BITS
03500 PUSH P,PNAME
03600 PUSH P,PNAME+1
03700 SETZM PNAME+1
03800 SETZM PNAME
03900 PUSHJ P,STRINS
04000 MOVEM PNT,NULLOC
04100 POP P,PNAME+1
04200 POP P,PNAME
04300 POP P,BITS
04400 JRST RETRT
04500
04600 ↑BINF: SKIPN LENCNT ;ARE WE INSIDEA SUBSTRING OPERATION??
04700 ERR (<∞ (INF) INVALID, 0 ASSUMED>,1,BFAL)
04800 HLRZ A,LENSTR ;LEFT HALF POINTS TO TOP OF QPUSH STACK.
04900 LEP <
05000 SKIPGE A,(A) ;NEG IF INF. WITHIN SUBLIST SELECTOR
05100 JRST LINF ;LIST INFIN. LOCATED IN LEAP
05200 >;LEP
05300 NOLEP <
05400 MOVE A,(A)
05500 >;NOLEP
05600
05700 MOVEM A,GENLEF+1 ;SET UP FOR LENGTH
05800 JRST LLEN1 ;MODIFIED FORM OF LENGTH.
05900
00100 DSCR TWID10, ECHK, ESET
00200 PRO TWID10, ECHK, ESET
00300 DES The "TWIDDLERS" which craftily manipulate the semantics
00400 stack entries. They are used to move things around when
00500 no other generators need be called, or when convenience warrents.
00600 ⊗
00700
00800 ↑TWID10: MOVE A,GENLEF+1 ;THIS MOVES FROM ENTRY 1
00900 MOVEM A,GENRIG ;TO ENTRY 0.
01000 POPJ P, ;EXAMPLE -- PRODUCTION "XID"
01100
01200
01300
01400 ;NOW FOR THE GENERALIZED EXPRESSION CHECKER. PASSED IS AN INDEX....
01500
01600 ↑ECHK: JRST @.+1(B) ;GO DO RIGHT THINGS.
01700 JRST CPOPJ ;REGULAR ARITH EXPRESSION.
01800 JRST LEVBOL ;BOOLEAN EXPRESSION .. CONVERT TO INTEGER.
01900 JRST LEAVE ;ASSOCIATIVE EXPR. -- CONVERT TO ITEM ..
02000
02100
02200 ; SAVE CLASS INDEX FOR PRODUCTIONS WHICH REFER TO TWO (FIRST)
02300
02400 ↑ESET: MOVEM B,THISE ;SAVE INDEX IF THIS CLASS
02500 POPJ P, ;HARDLY WORTH THE CALL
02600 ; (SHOULD HAVE WRITTEN?)
02700
02800 DSCR FDO1, FDO2
02900 PRO FDO1 FDO2
03000 DES LEAP function calling routines -- dipatch on class
03100 to proper LEAP routine.
03200 ⊗
03300
03400 ↑FDO1: JRST @.+1(B)
03500 JRST ISTRIP ;ISTRIPLE
03600 JRST SLOP ;STRING LOP
03700 JRST ECVN ;CVN
03800 JRST [SKIPN PNT,GENLEF+1
03900 JRST STCNT
04000 MOVE TBITS,$TBITS(PNT)
04100 TRNN TBITS,STRING!INTEGR
04200 JRST STCNT ;LENGTH OF SET.
04300 JRST LLEN ;STRING LENGTH
04400 ]
04500 REPEAT 2 ,<JRST BYPE> ;BYTE POINTER THINGS.
04600 JRST ECVN ;? ITEMVAR BOUND
04700
04800 ↑FDO2: JRST @.+1(B)
04900 SELET
05000 SELET
05100 SELET ;FIRST,SECOND,THIRD
05200 STUNT ;COP
05300 ECVI ;CVI
05400 SUBTTL EXECS for Handling Block Levels, Entering Variables
05500
00100 DSCR DWN, BLOCK, BLNAME, ENTID, UP, NAMCHK, etc.
00200 PRO DWNA DWN BLOCK BLNAME ENTID ENDDEC UP1 UP2 NAMCHK UPWOM
00300 DES These EXECS handle the declarations of a Block, from
00400 recursion of lexical state at BEGIN and END, to the actual
00500 entry of locals, to the checking of Block names.
00600 SEE comments following this DSCR for more information.
00700 ⊗
00800
00900
01000 Comment ⊗
01100
01200 These are the routines to process the entering and leaving of lexical levels.
01300
01400 DWN is called when a BEGIN is seen. It merely clears the boards in case
01500 some declarations come along.
01600
01700 BLOCK is called if it develops that this block is going to have declarations.
01800 The lexical level is incremented, and a new hash bucket is made.
01900 The block entry in the semantic stack is flagged as "declarations
02000 done in this block".
02100
02200 BLNAME is called if the block is going to have a name. This is independent
02300 of whether it has declarations or not. If there are no declarations,
02400 this is merely the name of a compound block.
02500
02600 ENTID is called to enter identifiers in the block. It basically calls
02700 ENTERS. But there is a lot of bookkeeping to do -- allocate
02800 item numbers, flag the block if arrays are declared, etc.
02900
03000 ENDDEC is called when all declarations are done. This puts out an
03100 ARMRK if arrays were declared, etc.
03200
03300 UP1 or UP2 is called when the block is exited.
03400 The block header is placed in a "block list" which is scanned
03500 at allocation time (end of procedure). Symbols, etc. are
03600 put out at that time.
03700
03800 NAMCHK is called to check to see if the respective BEGIN END pairs have
03900 corresponding names.
04000
04100 PACDO is called to protect acs for the duration of the block
04200
04300 ⊗
04400
04500
04600 ;COME HERE WHEN YOU SEE A BEGIN
04700
04800 ↑DWN: SETOM NODFSW ; SET FLAG TO DEFER PROCESSING OF DEFINES
04900 ; UNTIL A BLOCK HAS BEEN EXECUTED.
05000
05100 ↑DWN1: SETZM BITS ;IN CASE A CONSTANT WAS ENTERED
05200 SETZM GENRIG+1
05300 WOM <
05400 JUMPE B,DWNWOM
05500 >;WOM
05600 ;WHILE WE WERE AWAY!!!
05700 POPJ P, ;ALL DONE
05800
05900
06000
06100
06200
06300
06400
06500
06600 ↑OFFDEF: SETZM NODFSW ; TURN OFF FLAG WHICH DEFERS THE PROCESSING
06700 POPJ P, ; OF DEFINES UNTIL A BLOCK HAS BEEN
06800 ; EXECUTED.
06900
07000 ↑BLOCK: SETZM NODFSW ; TURN OFF FLAG WHICH CAUSES THE DEFERMENT
07100 ; OF DEFINE PROCESSING.
07200 AOS LEVEL
07300 MOVE A,VARB ;SAVE OLD CONTENTS.
07400 SETZM VARB ;RESTART VARB.
07500 SKIPN LPSA,GENLEF+1 ;"BLOCK" BLOCK THERE?
07600 GETBLK ; NO -- GET ONE.
07700 SKIPN QQFLAG ;IS THIS THE FIRST BLOCK WITH DECL'S?
07800 HRRZM LPSA,QQBLK ;YES, STORE IT FOR UNDEC
07900 SETOM QQFLAG
08000
08100 ;**** QQFLAG WILL HAVE TO BE INCLUDED IN THE INITIALZATION CODE EVENTUALLY****
08200 YESBB:
08300 HRROM LPSA,GENRIG+1 ;FLAG THAT DELCARATIONS HAVE BEEN DONE.
08400 PUSHJ P,RNGVRB ;PUT ON THE VARB RING
08500 HRL A,TTOP ;GET OLD TTOP
08600 MOVEM A,$ADR(LPSA) ;SAVE TTOP,,VARB.
08700 MOVEW (<$SBITS(LPSA)>,LEVEL) ;SAVE CURRENT LEVEL
08800 HRRM LPSA,TTOP ;NEW ONE
08900 HRRZ TEMP,NMLVL ;PICK IT UP HERE IN CASE BLNAME DOESN'T
09000 HRRM TEMP,$VAL2(LPSA) ;AND STORE IT IN DDT LEVEL LOCATION
09100
09200 PUSHJ P,MAKBUK ;MAKE A NEW SYMBOL BCKET
09300 MOVE LPSA,SYMTAB ; GET NEW BUCKET
09400 MOVE TEMP,GENRIG+1 ; GET THE BLOCK
09500 HRRM LPSA,%TBUCK(TEMP) ; STORE BUCKET FOR LATER HASH OF IDENTS
09600 JRST SHASH ;HASH AGAIN GIVEN THE NEW BUCKET
09700
09800
09900
10000
10100
10200
10300
10400 ↑CSNAME: TLO FF,FFTEMP ;NAMED CASE STATEMENT
10500 SETZM BITS ;DUPLICATE INITIAL CODE
10600 MOVE PNT,GENLEF ; BECAUSE
10700 MOVE LPSA,GENLEF+1 ; WE ALREADY HAVE A CASE BLOCK
10800 JRST FOXX ; LINK IT TO STRING RING AND CONTINUE
10900
11000 ↑BLNAME: TLZ FF,FFTEMP ;NAMED BLOCK,CPD STMT
11100 SETZM BITS
11200 MOVE PNT,GENLEF ;POINTER TO NAME CONSTANT.
11300 WOM <
11400 SKIPE LPSA,GENRIG ;IF THIS WAS AN "EX" THING
11500 JRST FOXX ;THEN DO NOT GET BLOCK
11600 >;WOM
11700 GETBLK <GENRIG> ;GET A BLOCK.
11800 FOXX: PUSHJ P,RNGSTR ;PUT ON THE STRING RING
11900 TLNE FF,FFTEMP ;CASE STMT?
12000 JRST CSVER ;YES, NO LABEL ISSUED
12100 AOS TEMP,NMLVL ;DDT (BLOCK NAME) LEVEL
12200 HRL TEMP,PCNT ;LOCATION OF FIRST WORD
12300 MOVEM TEMP,$VAL2(LPSA) ;STORE IN BLOCK BLOCK
12400 CSVER: MOVEI A,$PNAME-1(LPSA)
12500 PUSH A,$PNAME(PNT) ;RECORD NAME.
12600 PUSH A,$PNAME+1(PNT)
12700 SLS < ;ENTER BLOCK NAME
12800 QPUSH (PRGBSTK,PRGBLK) ;SAVE OLD PRGBLK VALUE
12900 TLNE FF,TOPLEV ;DIFFERENT PROCEDURE FOR TOP LEVEL
13000 JRST NOCRW
13100 SALCAL (SLBLK,<NMLVL>,<-PNT,$PNAME>) ;INSERT THIS BLOCK
13200 MOVEM A,PRGBLK ;UPDATE PRGBLK
13300 >;SLS
13400
13500 NOGAG <
13600 TLNN FF,CREFSW ;CREFFING?
13700 JRST NOCRW ;NO
13800 MOVEI A,15
13900 PUSHJ P,CREFOUT ;BLOCK NAME COMING.
14000 PUSHJ P,CREFASC ;AND CREF THE ASCII NAME OF BLOCK.
14100 >;NOGAG
14200 NOCRW:
14300 TLNN FF,FFTEMP ;CASE?
14400 TLNN FF,TOPLEV ;AT TOP LEVEL?
14500 POPJ P, ;NO
14600 MOVEI LPSA,IPROC+$PNAME-1 ;PUT IN PROGRAM NMAE.
14700 PUSH LPSA,$PNAME(PNT)
14800 PUSH LPSA,$PNAME+1(PNT)
14900 SLS < ;ENTER TITLE, OUTER BLOCK NAME
15000 SALCAL (SLPRG,<>,<-PNT,$PNAME>)
15100 MOVEM A,PRGBLK ;SET PRGBLK ID (SLS)
15200 >;SLS
15300 JRST MAKT ;MAKE A NEW PROGRAM HEADER.
15400
15500 ↑PACDO: MOVE LPSA,GENLEF+1 ;PICK UP AC NO TO SAVE
15600 MOVE D,$VAL(LPSA) ;
15700 CAIL D,0
15800 CAILE D,17
15900 ERR <ATTEMPT TO PROTECT A NUMBER NOT AN AC>,7
16000 ANDI D,17 ;IN CASE THE FOOL CONTINUES
16100 SKIPL B,ACKTAB(A)
16200 JRST .+3
16300 MOVE D,D ;FOR ERR UUO
16400 ERR <ATTEMPT TO PROTECT SOMETHING ALREADY PROTECTED>,7
16500 PUSHJ P,STORZ ;CLEAR THE AC
16600 HRROS ACKTAB(D) ;PROTECT IT
16700 HRLZI A,1
16800 LSH A,-1(D) ;ORING MASK
16900 MOVE LPSA,TTOP
17000 ORM A,$TBITS(LPSA) ;MARK BLOCK SEMBLK
17100 MOVEI A,12
17200 MOVEI B,4
17300 CNT1FA: SKIPL ACKTAB(A)
17400 SOJLE B,ENGHAC
17500 SOJGE A,CNT1FA
17600 ERR <NOT ENOUGH ACS LEFT UNPROTECTED>,1
17700 ENGHAC: POPJ P,
17800
00100 ↑ENTID:
00200 ORDENT:
00300 SKIPN PNT,NEWSYM
00400 JRST ENWAY ;NOT DEFINED BEFORE
00500 MOVE TBITS,$TBITS(PNT) ;GET CURRENT SEMANTICS
00600 TLNE TBITS,CNST ;DON'T LET CONSTANTS THROUGH
00700 ERR <DECLARING A CONSTANT -- CHECK MACROS>,1
00800 NOGAG <
00900 TLNN FF,CREFSW ;ARE WE CREFFING?
01000 JRST ENWAY ; NO
01100 MOVEI A,7 ;DELETE PREVIOUS ENTRY.
01200 PUSHJ P,CREFOUT
01300 >;NOGAG
01400 ENWAY:
01500 PUSHJ P,ENTERS ;DO THIS FIRST!!
01600 MOVE LPSA,NEWSYM
01700 PUSHJ P,GETADL ;GET GOOD BITS
01800 TLNE FF,PRODEF ;ARE WE SCANNING ID LIST
01900 JRST IDLIS ; YES
02000 MOVE A,[XWD SAFE,SET+INTEGR] ;CHECK ON KILL SET GUY
02100 TDC A,TBITS
02200 TDNE A,[XWD SAFE,SET+INTEGR] ;IS IT ??
02300 JRST EN.W1 ;NO
02400 TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR!PROCED]
02500 ERR <ILLEGAL DATA TYPE COMBINATION FOR KILL SET>
02600 EN.W1: TLNE TBITS,SBSCRP ;IF STRING ARRAYS, TURN
02700 TRZ TBITS,STRING ;OFF THE STRING PART.
02800 TRNE TBITS,ITEM!ITMVAR ;IGNORE DATUM TYPE OF ITEMS
02900 TRZ TBITS,STRING!BOOLEAN!INTEGR!SET!LSTBIT!FLOTNG
03000 MOVE PNT2,TTOP ;CURRENT BLOCK.
03100 TLNE TBITS,OWN ;IF OWN, THEN DONTSAVE BIT
03200 JRST IORDON ;
03300 SKIPN SIMPSW ;BETTER NOT LET SIMPLE DO ALLOC
03400 JRST .+3 ;HE ISNT SIMPLE
03500 TDNE TBITS,[XWD SBSCRP,SET] ;CHECK FOR BAD GUYS
03600 ERR <SIMPLE PROCEDURES MAY NOT ALLOCATE!>,1,IORDON
03700 IORM TBITS,$VAL(PNT2) ;THE "OR" OF ALL SYMBOLS DEFINED.
03800 IORDON:
03900 GLOC <
04000 TRNN TBITS,ITEM ;IF ITEM OR
04100 TRNN TBITS,GLOBL ;NOT GLOBAL, THEN GO ON
04200 JRST NOGLB
04300 TLNE FF,TOPLEV ;IF NOT AT TOP LEVEL
04400 TRNE TBITS,STRING!LABEL ;OR IF THESE RIDICULUOUS TYPES.
04500 ERR <INVALID GLOBAL TYPE>,1
04600 AOS A,GLOBCNT ;COUNT OF GLOBALS.
04700 CAILE A,GLBAR ;WITHIN BOUNDS OF GLOBAL AREA?
04800 ERR <TOO MUCH GLOBAL DATA>,1
04900 HRLM A,$VAL2(PNT) ;AND SAVE.
05000 GAG <
05100 ADDI A,400013 ;GLOBAL DATA BASE.
05200 HRRZM A,$ADR(PNT)
05300 >;GAG
05400 NOGLB:
05500 >;GLOC
05600 LEP <
05700 ; FOLLOWING REMOVED TO ALLOW INTRODUCTION OF STRING ITEMS.
05800 ; TRNN TBITS,LPARRAY
05900 ; JRST [TRNN TBITS,STRING
06000 ; JRST .+1
06100 ; TRNE TBITS,ITEM!ITMVAR
06200 ; ERR <STRING ITEMS NOT IN, ALTHOUGH STRING ARRAY ITEMS ARE>,1
06300 ; JRST .+1]
06400 NOGRUMP:
06500 TRNE TBITS,ITEM!ITMVAR!SET ;A LEAP DATA TYPE?
06600 SETOM LEAPIS ;TELL WORLD SOMEONE USED LEAP.
06700 TRNN TBITS,ITEM ;WAS IT AN ITEM?
06800 NOGAG < ;NOT DONE IF "GOGOL"
06900 POPJ P,
07000 >;NOGAG
07100 GAG <
07200 JRST ASSIGN ;ASSIGN A LOCATION TO IT
07300 >;GAG
07400 PUSH P,PNT ;SAVE ITEM SYMBOL POINTER
07500 PUSH P,BITS
07600 GLOC <
07700 TRNE TBITS,GLOBL ;IF A GLOBAL ITEM, THEN MAKE LEFT HALF
07800 SOSA A,GITEMNO
07900 >;GLOC
08000 AOS A,ITEMNO ;MAKE A NEW NUMBER FOR IT
08100 AOS ITMCNT ;TOTAL NUMBER OF DECLARED ITEMS
08200 GAG <
08300 GLOC <
08400 TRNE TBITS,GLOBL
08500 SOSA GITEMNO-SPCDAT+WOMSPC ;IN WOM SPACE BLOCK.
08600 >;GLOC
08700 AOS ITEMNO-SPCDAT+WOMSPC
08800 >;GAG
08900 PUSHJ P,CREINT ;MAKE AN INEGER OF ITEM NUMBER.
09000 MOVE PNT2,PNT
09100 PUSH P,A ;SAVE ITEM NUMBER
09200 SKIPN PNMSW ;PNAMES GOING NOW ?
09300 JRST NOPNM ;NO
09400 AOS PNMSW ;INDEX COUNT.
09500 NOGAG <
09600 PUSHJ P,STRINS ;MAKE ANOTHER COPY OF NAME
09700 HRL PNT,A ;ITEM NUMBER.
09800 QPUSH (PNLST,PNT) ;SAVE FOR LATER.
09900 NOPNM:
10000 MOVE A,-1(P) ;TYPE BITS
10100 PUSHJ P,ITMTYP ;GET TYPE INDEX
10200 HRL A,(P) ;ALSO ITEM NUMBER
10300 QPUSH (ITMSTK)
10400 POP P,A ;RESTORE A
10500 >;NOGAG
10600 GAG <
10700 MOVE SP,STPSAV
10800 PUSH SP,PNAME
10900 PUSH SP,PNAME+1
11000 PUSHJ P,[PUSHJ P,SAVE
11100 PUSH P,A ;ITEM NUMBER.
11200 PUSHJ P,NEW.PNAME
11300 MOVE LPSA,X11
11400 JRST RESTR]
11500 >;GAG
11600
11700 POP P,BITS
11800 POP P,LPSA
11900 ;; #KW# DON'T ALLOW INTERNAL OR EXTERNAL ITEMS
12000 MOVE TBITS,$TBITS(LPSA)
12100 TLZE TBITS,EXTRNL!INTRNL ;ITEMS CAN'T BE INTERNAL OR EXTERNAL
12200 ERR <ITEMS CAN'T BE INTERNAL OR EXTERNAL>,1
12300 MOVEM TBITS,$TBITS(LPSA)
12400 ;; #KW#
12500 MOVEM PNT2,$VAL2(LPSA) ;SAVE THE POINTER TO INTEGER!!!!
12600 POPJ P, ;EVEN IF "GOGOL", ITEMS DON'T NEED LOCATIONS
12700 >;LEP
12800
00100
00200 GAG <
00300 ↑ASSIGN:
00400 TRNN TBITS,GLOBL ;NEVER ASSIGN CORE FOR GLOBS.
00500 TRNE TBITS,ITEM!LABEL!PROCED ;DON'T ASSIGN LOCS TO THESE
00600 POPJ P,
00700 TLNE TBITS,EXTRNL ;ALREADY ASSIGNED IF EXTERNAL!
00800 POPJ P,
00900
01000 MOVEI B,0 ;BITS FOR VARSTK HEADER
01100 TRNE TBITS,STRING ;AS USUAL, THIS IS DIFFERENT
01200 JRST STRASS ; STRING ASSIGNMENT
01300 TRNE TBITS,SET ;DENOTE TYPE BY SOME SPECIAL BITS
01400 TRO B,1
01500 TLNE TBITS,SBSCRP ;ALSO MARK ARRAYS SO THEY CAN BE FOUND
01600 JRST [MOVE TBITS,$TBITS(PNT)
01700 TRNE TBITS,STRING
01800 TRO B,2 ;STRING ARRAY
01900 TRO B,4 ;SOME SORT OF ARRAY
02000 JRST .+1]
02100 PUSHJ P,VAROUT ;MAKE ROOM
02200 ASSBAK: HRRM TEMP,$ADR(PNT) ;STORE ADDR (OF 1ST IF STRING)
02300 SLS <
02400 SALCAL (SLSENT,<PRGBLK,PNT>,<-PNT,$PNAME>)
02500 >;SLS
02600 ; ABOVE PUTS OUT THE SYMBOL, RAT NOW.
02700 POPJ P,
02800
02900 STRASS: PUSHJ P,STVOUT ;ALMOST THE SAME
03000 HRLM TEMP,$ADR(PNT) ;ADDRESS OF SECOND WORD
03100 SOJA TEMP,ASSBAK ;GO MARK 1ST WORD ADDR
03200
03300 >;GAG
03400
03500 IDLIS: TRNN TBITS,PROCED
03600 TLNE TBITS,SBSCRP
03700 JRST [TLZE TBITS,VALUE
03800 ERR <VALUE PROCEDURE OR ARRAY CALLS NOT IMPLEMENTED>,1
03900 TLO TBITS,REFRNC
04000 TRZ TBITS,INPROG ;ONLY RELEVANT TO PROCED
04100 JRST IDFXN]
04200 TLNN TBITS,REFRNC
04300 TLO TBITS,VALUE ;IMPLIED VALUE
04400 IDFXN: TRNE TBITS,PROCED
04500 TLO TBITS,ANYTYP
04600 MOVEM TBITS,$TBITS(PNT)
04700 ;;#HR# 6-14-72 JRL HANDLE STRING ITEMVAR FORMAL PARAMETERS
04800 TRNE TBITS,ITEM!ITMVAR ;IGNORE STRING BIT IF ITEM
04900 TRZ TBITS,STRING
05000 ;;#HR#
05100 TRNE TBITS,STRING ;UPDATE THE STACK
05200 TLNE TBITS,REFRNC ;COUNTERS ACCORDING
05300 AOSA APARNO ;TO THE TYPE OF PARAMETER
05400 AOS SPARNO
05500 SLS < ;PUT OUT SYMBOL
05600 SALCAL (SLSENT,<PRGBLK,PNT>,<-PNT,$PNAME>)
05700 MOVEM A,LINKS
05800 >;SLS
05900
06000 POPJ P,
06100
06200
06300
06400
06500
06600 ↑ENDDEC:PUSHJ P,ENDJMP ;FIX UP JUMP AROUND PROCS, IF ANY
06700 JFCL ;IGNORE SKIPPEDNESS
06800 SKIPN LPSA,GENLEF+1 ;DID WE DEFINE ANYTHING?
06900 POPJ P, ;NO -- RETURN
07000 HRRZ TEMP,PCNT ;UPDATE LOC OF FIRST WORD OF BLOCK
07100 HRLM TEMP,$VAL2(LPSA)
07200 NODIS <
07300 MOVE TBITS,$VAL(LPSA) ;ALL TYPES OF SYMBOLS DECLARED.
07400 TLNN TBITS,SBSCRP ;ARRAYS DELCARED HERE?
07500 JRST ENDDE ;NO
07600 XCALL <ARMRK>
07700 >;NODIS
07800 ENDDE: TLZ FF,TOPLEV
07900 POPJ P, ;ALL DONE
08000
08100 ↑↑ENDJMP:
08200 MOVE TEMP,TPROC ;SURROUNDING PROCEDURE SEMANTICS
08300 HLRZ TEMP,%TLINK(TEMP) ;2D PROC BLOCK
08400 SKIPN B,$SBITS(TEMP) ;DID ANYBODY JUMP? (SEE PRDEC)
08500 JRST CPOPJ1 ; NOBODY DID
08600 SETZM $SBITS(TEMP) ;CLEAR FOR NEXT TIME
08700 HRL B,PCNT
08800 JRST FBOSWP ;NOW FIX UP JUMP AND QUIT
08900 ↑CPOPJ1:AOS (P) ;THE CANONICAL SKIP-RETURN
09000 POPJ P, ;DONE
09100
09200 ;HERE WHEN YOU SEE THE MATCHING "END"
09300
09400 ↑UP1: SKIPA PNT,GENLEF+1 ;FOR CODE_BEGIN SEQUENCES
09500 ↑UP2: MOVE PNT,GENLEF+2 ;BEGIN SEMANTICS.
09600 UPPP: MOVEM PNT,GENRIG ;SAVE FOR NAME CHECKING.
09700 JUMPE PNT,NMSUB ;NO BLOCK ASSOCIATED WITH THIS BEGIN
09800 JUMPL PNT,UPCHK ;THIS BLOCK HAS DECLARATIONS ...
09900 SKIPN $PNAME(PNT) ;NAMED COMPOUND STATEMENT?
10000 JRST NONM ; NO, FORGET IT
10100 HRRZS PNT ;LH 0 TO INDICATE PRESENCE OF NAME
10200 QPUSH (BLKIDX,PNT) ;PUT CPD STMT SEMBLK IN STACK
10300 SETZM %RVARB(PNT) ;MAKE SURE THERE'S NO LIST
10400 SOS NMLVL ;LOWER DDT LEVEL BY ONE
10500 SLS <
10600 QPOP (PRGBSTK) ;OLD PRGBLK ID
10700 MOVEM A,PRGBLK ;RESTORE
10800 >;SLS
10900 CREFWQ:
11000 NOGAG <
11100 TLNN FF,CREFSW ;CREFFING ?
11200 >;NOGAG
11300 POPJ P, ;DON'T DELETE THE BLOCK
11400 NOGAG <
11500 MOVEI LPSA,(PNT) ; POINTER TO BLOCK.
11600 JRST CREFBLOCK ;AND CREF BLOCK EXIT.
11700 >;NOGAG
11800
11900 NONM: MOVE LPSA,PNT
12000 PUSHJ P,URGSTR ;IN CASE IT WAS A NAMED BLOCK..!!
12100 FREBLK <PNT>
12200 NMSUB: POPJ P,
12300
12400
12500 UPCHK: PUSHJ P,GOSTO ;STORE EVERYONE
12600 MOVE TBITS,$VAL(PNT)
12700 NODIS <
12800 TLNN TBITS,SBSCRP ;WERE ARRAYS DELCARED IN THIS BLOCK?
12900 JRST EMJR ;NO
13000 XCALL <ARREL> ;RELEASE THEM.
13100 >;NODIS
13200
13300 DIS <
13400 ;;#KT# ↓ TYPO AS TO WHERE KILL SET IS
13500 HRRZ C,$ACNO(PNT) ;IF WE HAVE A KILL LIST
13600 JUMPN C,DBEX ;MUST BEXIT
13700 LDB C,[POINT LLFLDL,$SBITS(PNT),35] ;PICK UP LEXIC LEVEL
13800 CAIE C,1 ; IF NOT GLOBAL AND
13900 TDNN TBITS,[ XWD SBSCRP,SET] ;IF ONE OF THE BAD GUYS
14000 JRST EMJR ;THINGS ARENT SO EASY
14100 ;;#KX# 1-9-73 DO ALLSTO BEFORE YOU BEXIT -- RHT
14200 DBEX: PUSHJ P,ALLSTO ;
14300 HRR C,PCNT
14400 HLL C,$SBITS(PNT)
14500 HRLM C,$SBITS(PNT) ;FIXUP BK LVI REF
14600 EMIT <MOVEI LPSA,NOUSAC!USADDR>
14700 XCALL <BEXIT>
14800 >;DIS
14900
15000
15100
15200 EMJR: HRROS PNT ;ASSUME NO NAME
15300 SKIPE $PNAME(PNT)
15400 JRST [HRRZS PNT ;WRONG AGAIN
15500 SOS NMLVL ;NAME LEVEL
15600 PUSHJ P,CREFWQ ;POSSIBLY CREF BLOCK EXIT.
15700 SLS <
15800 QPOP (PRGBSTK) ;RESTORE PRGBLK ID
15900 MOVEM A,PRGBLK
16000 >;SLS
16100 JRST .+1]
16200 HLRZ A,$TBITS(PNT) ;BITS OF PROTECTED ACS
16300 COMMENT ⊗ HORRIBLE LOOP TO UNDO PROTECTION OF ACS IN THIS BLOCK ⊗
16400 PUSH P,B
16500 PUSH P,D
16600 MOVEI D,11
16700 MOVEI B,1000 ;BIT FOR AC 11
16800 UPACHK: TDZE A,B ;DID WE PROTECT IT
16900 HRRZS ACKTAB(D) ;UNPROTECT IT
17000 LSH B,-1
17100 SOJGE D,UPACHK ;
17200 POP P,D
17300 POP P,B
17400 ;**************************************
17500 QPUSH(BLKIDX,PNT)
17600 MOVE A,$ADR(PNT)
17700 HLRM A,TTOP ;RESTORE IT.
17800 HRRM A,VARB ;RESTORE THE VARB POINTER.
17900 SOS LEVEL
18000 JRST FREBUK ;come up a level in symbol buckets.
18100
00100 ; Check for match on block names.
00200
00300 ↑NAMCHK: SKIPN PNT,GENLEF+1 ;BLOCK SEMANTICS.
00400 JRST NMCHKK
00500 MOVE PNT2,GENLEF ;END NAMED.
00600 MOVE A,$PNAME+1(PNT) ;BYTE POINTER.
00700 JUMPE A,NMCHKK ;BLOCK UNNAMED
00800 CAMN A,$PNAME+1(PNT2) ;AND THE OTHER
00900 POPJ P,
01000 JRST MTCERR ;NO GOOD
01100 NMCHKK: MOVE TEMP,TPROC ;TRY FOR MATCH WITH
01200 MOVE PNT2,GENLEF ;END NAMED
01300 MOVE A,@$PNAME+1(TEMP) ;CURRENT PROC NAME
01400 CAMN A,@$PNAME+1(PNT2) ; (FIRST WORD MATCH ONLY)
01500 POPJ P,
01600 SKIPN PNT
01700 ERR <NAME AFTER UNNAMED BLOCK!>,1,CPOPJ
01800 MTCERR: ERR <NAMES OF BEGIN AND END DO NOT MATCH>,1
01900 POPJ P,
02000
02100
02200
02300
02400 WOM <
02500 ;ROUTINES FOR EXECUTE AND THROW OUT PARTS OF CODE....
02600
02700 DWNWOM: PUSH P,PCNT
02800 PUSH P,CODSTK
02900 PUSH P,CODSTK+1
03000 PUSH P,CODSTK+2 ;SAVE LOTS.
03100 GETBLK <GENRIG> ;GOT A BLOCK.
03200 GETBLK ;AND ANOTHER
03300 MOVEM LPSA,@GENRIG ; BLOCK BLOCK POINTS TO EX BLOCK.
03400 HRLI LPSA,-3(P) ;
03500 HRRI B,3(LPSA) ;
03600 BLT LPSA,(B) ;STORE IN NEW BLOCK.
03700 SUB P,X44
03800 POPJ P,
03900
04000 ↑UPWOM: PUSHJ P,ALLSTO
04100 MOVE SP,GENLEF+2 ;BEGIN BLOCK.
04200 MOVE SP,(SP) ; → TO EX BLOCK INFO.
04300 HRLI C,RETTN ;RETURN ADDRESS.
04400 EMIT (JRST NOUSAC!NORLC!USADDR)
04500
04600 PUSH P,SP
04700 PUSH P,FF
04800
04900 MOVE SP,STPSAV ;STRING STACK....
05000 MOVE A,@-1(P) ; ADDRESS OF STATEMENT.
05100 JRST (A) ;GO OF AND HOPE TO RETURN.
05200
05300 RETTN: POP P,FF
05400 POP P,SP
05500
05600 COMUP: MOVE B,1(SP) ;CODSTK.
05700 CAMN B,CODSTK ;SAME BLOCK?
05800 JRST OKK ;YES -- JUST ADJUST CNTS.
05900 HRRZ C,-2(B) ;→ PREV.
06000 PUSHJ P,CORREL
06100 MOVE B,C
06200 JRST COMUP
06300 OKK: HRROI A,3(SP)
06400 POP A,CODSTK+2
06500 POP A,CODSTK+1
06600 POP A,CODSTK
06700 POP A,PCNT
06800 FREBLK (SP)
06900 JRST UP2 ;AND ACT AS IF COMING UP FROM BLOCK.
07000
07100 >;WOM
07200
07300 SUBTTL EXECS for REQUIRE Verb
07400
00100 DSCR RQ00, RQSET, SRCSWT
00200 PRO RQ00 RQSET SRCSWT REQERR
00300 DES These routines handle the REQUIRE Syntax of the forms:
00400
00500 | | PNAMES
00600 | | SYSTEM_PDL
00700 | | STRING_PDL
00800 | n | STRING_SPACE
00900 | | ARRAY_PDL
01000 | | NEW_ITEMS
01100 | | VERSION
01200 REQUIRE |-----------------------|
01300 | | LIBRARY
01400 | | LOAD_MODULE
01500 | "file description" | SEGMENT_FILE
01600 | | SEGMENT_NAME
01700 | | SOURCE_FILE
01800 |-----------------------|
01900 | "2 or 4 characters" | DELIMITERS
02000 |-----------------------|
02100 PNAMES and SOURCE_FILE are handled specially
02200 ⊗
02300
02400
02500 ↑RQ00: SETZM SCNVAL ;IN CASE NO NUMBER IS GIVEN.
02600 ZPOPJ: POPJ P,
02700 ↑RQSET:
02800 SETZM BITS ;IN CASE UNARY WAS CALLED
02900 LEP <
03000 JUMPE B,PNAM ;PNAMES......
03100 >;LEP
03200 MOVE A,SCNVAL ;THE CONSTANT
03300 XCT RQTAB-1(B) ;DO SOMETHING
03400 POPJ P,
03500
03600 RECORD: HRRZ TEMP,SPCTBL ;THE SPACE RESERVATIN TABLE
03700 ADDI TEMP,1 ;ONE MORE WORD
03800 HRRM TEMP,SPCTBL ;HOPEFULLY
03900 CAIN TEMP,=18 ;OVERFLOW?
04000 ERR <TOO MANY SPACE REQUIRES>,1
04100 CAILE TEMP,=17 ;PREVIOUS OVERFLOW?
04200 POPJ P, ;YES
04300 HRL A,B ;THE INDEX INDICATES WHICH
04400 TLO A,STDSPC ; SPACE IS REQUESTED
04500 MOVEM A,SPCTBL+1(TEMP) ;INTO LOADER BLOCK FOR LATER OUTPUT
04600 POPJ P,
04700
04800 RQTAB: JRST RECORD ;SYSTEM PDL
04900 JRST RECORD ;STRING PDL
05000 JRST RECORD ;STRING SPACE
05100 JFCL ;ARRAY PDL NO LONGER EXISTS
05200 MOVEM A,NWITM ;NEW ITEMS.
05300 MOVEM A,VERNO ;VERSION NUMBER
05400 JRST LBSET ;LIBRARY REQUEST
05500 JRST PRGSET ;LOAD MODULE REQUEST.
05600 JRST REQERR ;SOMETHING WRONG WITH SOURCE_FILE RQST
05700 JRST DELSTG ; PROCESS REQUIRE DELIMITERS COMMAND
05800 JRST REPDEL ; PROCESS REPPLACE DELIMITERS COMMAND
05900 JRST POPDEL ; PROCESS POP_DELIMITERS COMMAND
06000 JRST NULDEL ; PROCESS NULL_DELIMITERS COMMAND
06100 GLOC < ;REQUESTS FOR SEGMENT NAMES, ETC.
06200 JRST SEGSET ;LOGICAL SEGMENT NAME REQUEST
06300 JRST SEGFL ;SEGMENT FILE NAME REQUEST
06400 >;GLOC
06500 JRST INMAIN ;GO INITIALIZE MAINPR
06600 JRST REQPLL ; POLLING INTERVAL
06700
00100
00200 NOGAG <
00300 LBSET: SKIPA B,[LBTAB] ;LIBRARY OUTPUT BLOCK ADDR
00400 PRGSET: MOVEI B,PRGTAB ;PROGRAM OUTPUT BLOCK ADDR
00500 GETSEM (1) ;SEMANTICS OF STRING CONST
00600 HRROI TEMP,$PNAME+1(PNT)
00700 POP TEMP,PNAME+1
00800 POP TEMP,PNAME ;SET UP FOR CALL
00900 JRST PRGOUT ;OUTPUT REQUEST, RETURN
01000
01100 >;NOGAG
01200
01300 GLOC <
01400 SEGSET: PUSHJ P,GETSOM ;GET NAME, SET UP TABLE POINTER
01500 MOVEM C,SEGNAM ;NAME ONLY, PUT IN SPACE BLOCK
01600 POPJ P,
01700
01800 SEGFL: PUSHJ P,GETSOM
01900 JUMPN A,.+2 ;DEVICE
02000 MOVSI A,(<SIXBIT /DSK/>) ;DEFAULT
02100 MOVEM A,SEGDEV ;DEVICE NAME
02200 MOVEM C,SEGFIL ;FILE NAME
02300 MOVEM D,SEGPPN ;WHEEE (TRANSLATION -- PPN)
02400 POPJ P,
02500
00100
00200 GETSOM: GETSEM (1) ;→STRING REPRESENTING REQUEST
00300 HRROI TEMP,$PNAME+1(PNT) ;PNAME
00400 POP TEMP,PNAME+1
00500 POP TEMP,PNAME
00600 JRST FILSCN ;CONVERT TO SIXBIT IN A,C,D
00700 >;GLOC
00800
00900 DELSTG: GETSEM (1) ; GET POINTER TO STRING SEMBLK
01000 TLNE TBITS,CNST ; CONSTANT?
01100 TRNN TBITS,STRING ; STRING?
01200 ERR <NOT A STRING CONSTANT - STATEMENT IGNORED>,1,CPOPJ ;
01300
01400
01500 ↑GETDEL: HRRZ LPSA,$PNAME(PNT) ; GET STRING CHARACTER COUNT
01600 JUMPE LPSA,NULDEL ; NULL DELIMITER STRING?
01700 MOVE PNT,$PNAME+1(PNT)
01800 QPUSH (DELSTK,<(PNT)>) ; SAVE THE DELIMITERS
01900 GETDL1: SETOM REQDLM
02000 MOVE TEMP,[XWD -DELNUM,0] ; FOR AOBJN
02100 ↑GETDL2:SOJGE LPSA,.+2 ; DELIMITER SCANNER LOOP
02200 ERR <NOT ENOUGH DELIMITERS IN INPUT - GARBAGE IN REST> ;
02300 ILDB B,PNT ; GET NEXT DELIMITER
02400 SKIPG SCNTBL(B) ; SPECIAL OR IGNORABLE?
02500 JRST GETDL2 ; YES, GET NEXT
02600 SKIPN SWBODY ; SPECIAL DELIMITER DEFINITION?
02700 MOVEM B,LOCMBD(TEMP) ; NO, STORE FOR PERMANENT REFERENCE
02800 MOVEM B,CURMBG(TEMP) ; STORE FOR TEMPORARY REFERENCE
02900 AOBJN TEMP,GETDL2 ; CHECK IF DONE
03000 POPJ P, ; YES
03100
03200 REPDEL: QPOP (DELSTK)
03300 JRST DELSTG
03400
03500 POPDEL: QPOP (DELSTK)
03600 QLOOK(DELSTK) ; GET A POINTER TO TOP ELEMENT OF DELSTK
03700 SETZM REQDLM
03800 SKIPN (A)
03900 POPJ P,
04000 HRLI A,(<POINT 7,0>)
04100 MOVE PNT,A
04200 MOVEI LPSA,DELNUM
04300 JRST GETDL1
04400
04500 NULDEL: SETZM REQDLM
04600 QPUSH (DELSTK,REQDLM)
04700 POPJ P,
04800
04900 ↑MKNSTB: MOVEI C,1 ; INITIALIZE COUNT FOR NESTABLE CHARS.
05000 MOVEI A,NUMCHA ; NUMBER OF CHARACTERS
05100 CONCNV: SOJL A,CPOPJ ; DONE?
05200 MOVE B,SCNTBL(A) ; LOAD AND TEST IF NESTABLE CHARACTER
05300 TLNN B,NEST ;
05400 JRST CONCNV ; NO, GET NEXT CHAR
05500 MOVEM C,NSTABL(A) ; YES, NSTABL CONTAINS INDEX AMOUNT
05600 ; TO BE ADDED TO LOCNST
05700 TLNE B,LNEST ; DONE WITH A NESTED PAIR?
05800 ADDI C,1 ; YES, INCREMENT COUNTER
05900 JRST CONCNV ; GET NEXT
06000
00100 ↑SRCSWT:
00200 ; FIRST CHECK VALIDITY OF SOURCE_FILE SWITCHING RQST, SET SPECIAL SWITCHER
00300 MOVE TBITS2,SCNWRD
00400 TLNE TBITS2,MACIN ;IF IN MACRO, ILLEGAL
00500 ERR <DON'T SWITCH SOURCE FILES INSIDE MACRO>,1,SCANNER
00600 SETOM SRCDLY ;FLAG SCANNER
00700 POPJ P,
00800
00900 ; NOW TRY THE SWITCH-OVER
01000
01100 ; CHECK IF THE FILE WAS ACTUALLY SWITCHED
01200 ↑SRCCHK: SKIPE SRCDLY ;WILL BE ZERO IF SWITCHED
01300 ERR <SOURCE FILE REQUEST MUST END LINE>
01400 POPJ P,
01500
01600 ↑REQERR: ERR <INVALID SYNTAX -- SOURCE FILE REQUEST>,1
01700 POPJ P,
01800
01900 SUBTTL EXECS for MACRO (DEFINE) Declarations
02000
00100 DSCR DFPREP, DCPREP, DWPREP, DFPINS, DFSET, DFENT, MACOFF
00200 PRO DFPREP DCPREP, DWPREP, DFPINS DFSET DFENT MACOFF
00300 DES Execs for syntax
00400 DEFINE macnam(a1,a2..)="macro body", macnam2=....,...;
00500 Relies heavily on mechanisms built into the SCANNER to
00600 parse the macro body, insert parameters.
00700 SEE SCANNER
00800 ⊗
00900 Comment *
01000 DFR: @I ( → DPL EXEC DFPR1 SCAN 2 GO TO DPA
01100 @I SG → DPL SG EXEC DFPREP GO TO LEQ OR GO TO Q0
01200
01300 DFPREP -- prepare to define a macro body.
01400 Enter DEFINE symbol. Use current def if
01500 it's at the same level (done in ENTER). Get
01600 a new symbol table bucket.
01700
01800 DCPREP -- prepare to define a conditional compilation CASEC body.
01900 Check if first casec and if not then enter the computed
02000 casec value in the $VAL2 entry of the semblk obtained for
02100 the casec body.
02200
02300 DWPREP -- prepare to define a conditional compilation WHILEC, FORC,
02400 or FORLC body. *
02500
02600 ↑MACOFF: TLO FF,NOMACR ;NO MACRO EXPANSIONS WHEN REDEFINING!
02700 POPJ P,
02800
02900 ↑DCPREP: GETBLK NEWSYM ; SEMBLK FOR CASEC BODY
03000 GETSEM (1) ; SEMANTICS OF CASEC NUMBER
03100 MOVE TEMP,$VAL(PNT) ; GET CASEC NUMBER
03200 JUMPN TEMP,NOFRST ; TWIDDLE IF NOT FIRST CASEC
03300 PUSHJ P,CPSHEN ; SET ENDC DOESN'T TRIGGER A PARSER SWITCH FLAG
03400 SETOM SWCPRS ; PARSER SWITCHING IS OK (I.E. IFC IN BODY OF CASEC
03500 ; TO BE EXECUTED)
03600 JRST CMPRP2 ; DON'T TWIDDLE SINCE FIRST CASEC
03700 NOFRST: MOVEM TEMP,$VAL2(LPSA) ; STORE CASEC NUMBER IN $VAL2 OF THE SEMBLK
03800 MOVEM LPSA,GENRIG+1 ; SAVE SEMANTICS OF PSEUDO MACRO BODY SEMBLK
03900 MOVE TEMP,%CFLS1 ; TWIDDLE
04000 MOVEM TEMP,PARRIG ; NOT THE FIRST CASEC
04100 JRST DWPRP1 ; REST OF MACRO BODY PRELIMINARIES
04200
04300 ↑DWPREP: GETBLK NEWSYM ; SEMBLK FOR WHILEC, FORC, OR FORLC BODY
04400 DWPRP1: HRLZI TEMP,DEFINE ; GET GOOD BITS
04500 MOVEM TEMP,$TBITS(LPSA) ; SET SEMBLK DESCRIPTOR
04600 HRRZS %TLINK(LPSA) ; ZERO THE MACRO BODY DEFINITION LINK
04700 JRST CMPRP2 ; REST OF MACRO BODY PRELIMINARIES
04800
04900 ↑DFPREP: HRLZI TEMP,DEFINE ; GET GOOD BITS
05000 MOVEM TEMP,BITS ; PREPARE TO DO AN ENTERS
05100 PUSHJ P,ENTERS ; ENTER MACRO NAME IF NOT ALREADY DEFINED
05200 MOVE LPSA,VARB ; CHECK IF DEFINE IS HAPPENING BEFORE THE
05300 SKIPN LEVEL ; OUTER LEVEL BLOCK HAS BEEN STARTED. IF
05400 MOVEI LPSA,RESYM ; YES, THEN SET VARB TO RESYM SO DONES WILL
05500 MOVEM LPSA,VARB ; WORK PROPERLY.
05600 CMPRP2: PUSHJ P,MAKBUK ;DOWN ONE LEVEL FOR PARAMETERS
05700 AOS LEVEL
05800 MOVE LPSA,NEWSYM ;SYMANTICS OF ENTRY
05900 MOVEM LPSA,GENRIG ;MAY BE GARBAGING "="'S SEMANTICS
06000 MOVE TEMP,VARB ;SAVE VARB LIST -- WILL LINK FORMALS
06100 MOVEM TEMP,$ADR(LPSA) ; OLD VARB POINTER IS SAVED IN $ADR SO THAT
06200 ; THE MACRO BODY IS STILL KNOWN
06300 SETZM VARB
06400 HLLZS $VAL(LPSA) ;CLEAR #PARAMS COUNT (SAVE COUNT FOR PREV DEF).
06500 SETZM $ACNO(LPSA) ;WILL POINT AT FIRST PARAM
06600 TLZ FF,NOMACR ;MACROS EXPANDED AGAIN
06700 POPJ P,
06800
06900
07000 Comment ⊗
07100 DPA: SG @I , → SG EXEC DFPINS SCAN 2 ¬DPA
07200 SG @I ) → SG EXEC DFPINS SCAN ¬LEQ #Q0
07300 Insert macro parameter:
07400 1. Enter the symbol
07500 2. Insert in list off %TLINK in macro name semantics ⊗
07600
07700 ↑MDFPNS: TLZ FF,NOMACR ; MACROS EXPANDED AGAIN WHEN THROUGH SCANNING
07800 ; FORMALS
07900 ↑DFPINS: HRLZI TEMP,FORMAL!DEFINE ;ENTER PARAM (LINK ON SPECIAL VARB RING)
08000 MOVEM TEMP,BITS
08100 PUSHJ P,ENTERS
08200 MOVE TEMP,GENLEF+2 ;SEMANTICS FOR MACRO NAME
08300 AOS A,$VAL(TEMP) ;COUNT MACRO PARAMS
08400 MOVE LPSA,NEWSYM ;SEMANTICS OF THIS PARAM
08500 SKIPN $ACNO(TEMP) ;IS THIS THE FIRST ONE?
08600 MOVEM LPSA,$ACNO(TEMP) ; YES, STORE POINTER TO FIRST
08700 HRRZM A,$VAL(LPSA) ;STORE PARAM NUMBER
08800 POPJ P,
08900
09000
09100
09200 Comment ⊗
09300 LEQ: STC → EXEC SPDMBD SCAN ¬LEQ1
09400 Check if a special macro body delimiter declaration has occurred ⊗
09500
09600 ↑SPDMBD: SETOM SWBODY ; SET SWITCH DELIMITER DECLARATION FLAG
09700 MOVE TEMP,[XWD -2,0] ; SET UP A COUNT
09800 MOVE PNT,GENLEF ; GET SEMBLK ADDRESS OF STRING
09900 HRRZ LPSA,$PNAME(PNT) ; GET READY FOR A SPECIAL DELIMITER MODE
10000 MOVE PNT,$PNAME+1(PNT) ; SCAN
10100 JRST GETDL2 ; GET SPECIAL DELIMITERS
10200
10300
10400 Comment ⊗
10500 LEQ1: = → EXEC DFSET SCAN 2 ¬DEQ #Q0
10600 Get ready for macro body ⊗
10700
10800 ↑DFSET: JRST FFPUSH ; SAVE DEFLUK BIT OF FF AND TURN IT ON IN FF
10900
11000
11100 Comment ⊗
11200 DEQ: DPL ICN , → EXEC DFINE SCAN 2 ¬DFR
11300 DDEF DPL ICN ; → EXEC DFINE SCAN ¬DS0
11400 SDEF DPL ICN ; → EXEC DFINE SCAN ¬S1 #Q0
11500
11600 Eradicate formal parameter ring, turn off special
11700 string mode bit after macro scan -- install the macro body. ⊗
11800
11900 ↑DFENT1: MOVE A,GENLEF+3 ; SEMBLK OF CASEC ENTRY
12000 JRST NOREDF ; NO PARAMETER LIST TO DELETE
12100 ↑DFENT: MOVE A,GENLEF+2 ; GET SEMBLK ADDRESS
12200 MOVE LPSA,$ACNO(A) ; FORMAL LIST
12300 PUSHJ P,KILLST ;DELETE FORMAL PARAM LIST
12400 SETZM $ACNO(A) ; NO MORE LIST
12500 HRRZ TEMP,$VAL(A) ; #PARAMS FOR THIS (NEW) DEFINITION
12600 HRLZM TEMP,$VAL(A) ; #PARAMS FOR CURRENTLY ACTIVE DEF.
12700 HLRZ LPSA,%TLINK(A) ; CHECK IF THE MACRO HAS BEEN PREVIOUSLY
12800 JUMPE LPSA,NOREDF ; DEFINED, AND IF YES
12900 PUSHJ P,KILLST ; DELETE THE PREVIOUS DEFINITION
13000 NOREDF: MOVE TEMP,$ADR(A) ; RESTORE SAVED VARB POINTER
13100 MOVEM TEMP,VARB ; (IT WAS USED TO KEEP FORMALS LOCATED)
13200 MOVE LPSA,GENLEF+1 ;MACRO BODY (STRING CONST) SEMANTICS
13300 HRLM LPSA,%TLINK(A) ; STORE IN %TLINK FIELD
13400 MOVE TBITS,$TBITS(LPSA) ; GET GOOD BITS
13500 TRNE TBITS,STRING ; TEST IF A STRING AND SET IT TO STRING
13600 JRST NOCNST ; YES, NO NEED TO CONVERT CONSTANT TO STRING
13700 PUSH P,$VAL(LPSA) ; PUSH VALUE
13800 PUSHJ P,REMOPL ; DELETE SEMBLK OF NUMERIC CONSTANT IF POSSIBLE
13900 EXCH SP,STPSAV ; GET STRING POINTER
14000 MOVSS POVTAB+6 ;*ENABLE CORRECT MESSAGE -- DCS 4-9-72
14100 PUSHJ P,CVS ; CONVERT TO STRING
14200 POP SP,PNAME+1 ;*FIRST WORD OF STRING DESCRIPTOR
14300 POP SP,PNAME ;*SECOND WORD OF STRING DESCRIPTOR
14400 EXCH SP,STPSAV ; RETURN STRING POINTER
14500 MOVSS POVTAB+6 ;*KEEP ERROR MESSAGES IN SYNCH -- DCS 4-9-72
14600 PUSHJ P,STRINS ;*MAKE STRING CONSTANT -- DCS 4-16-72
14700 MOVEM PNT,GENLEF+1 ;*RECORD RESULTS WHERE WILL BE SEEN
14800 MOVE LPSA,GENLEF+2 ;*MACRO NAME SEMBLK AGAIN -- DCS 4-16
14900 HRLM PNT,%TLINK(LPSA);*FILL IN THE REAL GUY -- DCS 4-16
15000 NOCNST: SOS LEVEL
15100 PUSHJ P,FREBUK ;RETURN UP
15200 JRST CLRSET ;CLEAR BITS
15300
15400 ↑SWDLM: SKIPN SWBODY ; NEED TO SWAP MACRO BODY DELIMITERS?
15500 POPJ P, ; NO, RETURN
15600 HRROI TEMP,LOCMBD+1 ; GET RESTORING ADDRESS
15700 POP TEMP,CURMED ; RESTORE START DELIMITER
15800 POP TEMP,CURMBG ; RESTORE END DELIMITER
15900 SETZM SWBODY ; RESET SWITCH DELIMITERS FLAG
16000 POPJ P, ; RETURN
16100
16200 ↑SETDLM: QPUSH(LOKDLM,DLMSTG) ; SAVE CURRENT DLMSTG VALUE
16300 SKIPE REQDLM ; SPECIAL DELIMITER MODE?
16400 SETOM DLMSTG ; YES, POSSIBLY LOOKING FOR DELIMITED STRING
16500 POPJ P, ; RETURN
16600
16700 ↑OFFDLM: QPOP(LOKDLM,DLMSTG) ; CEASE LOOKING FOR DELIMITED STRING
16800 POPJ P, ; RETURN
16900
17000 ↑ENDMAC: MOVE TEMP,GENLEF+1 ; GET MACRO BODY SEMBLK
17100 EXCH SP,STPSAV ; GET STRING POINTER
17200 PUSH SP,$PNAME(TEMP) ; FIRST WORD OF STRING DESCRIPTOR
17300 PUSH SP,$PNAME+1(TEMP) ; SECOND WORD OF STRING DESCRIPTOR
17400 PUSH SP,[XWD 0,2] ; LENGTH OF FOLLOWING STRING
17500 PUSH SP,[POINT 7,[BYTE (7) 177 0]] ; END OF MACRO STRING
17600 PUSHJ P,CAT ; CONCATENATE
17700 MOVE TEMP,GENLEF+1 ; GET MACRO BODY SEMBLK
17800 POP SP,$PNAME+1(TEMP) ; SECOND WORD OF STRING DESCRIPTOR
17900 POP SP,$PNAME(TEMP) ; FIRST WORD OF STRING DESCRIPTOR
18000 EXCH SP,STPSAV ; RETURN STRING POINTER
18100 POPJ P, ; RETURN
18200
18300 ↑SWPON: SETOM SWCPRS ; SWITCHING PARSERS IS ALLOWED
18400 POPJ P, ; RETURN
18500
00100 DSCR STCAT
00200 PRO STCAT
00300 DES Converts a macro body to a string.
00400 CVMS(macname). If called with a macro name and a parameter list, then
00500 the parameters are ignored and a suitable error message is emitted.
00600 ⊗
00700
00800 ↑STCAT: MOVE LPSA,GENLEF ; PREPARE TO LOOK UP THE STRING
00900 HLRZ LPSA,%TLINK(LPSA) ; AND ENTER IT IN THE SYMBOL
01000 MOVE TEMP,$PNAME(LPSA) ; TABLE IF NOT ALREADY THERE.
01100 SUBI TEMP,2 ; THE ONLY DIFFERENCE BETWEEN THE
01200 MOVEM TEMP,PNAME ; STRING AND THE MACRO BODY IS
01300 MOVE TEMP,$PNAME+1(LPSA) ; THAT THE STRING DOES NOT HAVE
01400 MOVEM TEMP,PNAME+1 ; 177-0 AT ITS END.
01500 MOVE LPSA,STRCON ;
01600 MOVEW HSPNT,HPNT ;
01700 PUSHJ P,SHASH ;
01800 SKIPE LPSA,NEWSYM ;
01900 JRST NOENTR ;
02000 PUSH P,BITS ;
02100 MOVE TEMP,[XWD CNST,STRING] ;
02200 MOVEM TEMP,BITS ;
02300 PUSHJ P,ENTERS ;
02400 POP P,BITS ;
02500 MOVE LPSA,NEWSYM ; SET THE SEMANTIC STACK ENTRY TO
02600 NOENTR: MOVEM LPSA,GENRIG ; THE SEMBLK ADDRESS OF THE STRING.
02700 TLZ FF,NOMACR ; TURN MACRO EXPANSION BACK ON
02800 POPJ P, ;
02900
03000
03100 DSCR DCLINT
03200 PRO DCLINT
03300 DES This routine is used to process a DECLARATION(varname) command which looks
03400 up the varname in the symbol table and returns an integer having the value of
03500 the $TBITS entry in the symbol table. If the variable has not been declared,
03600 then a zero is returned. Note that macro names are not expanded here. Also,
03700 turn off the OWN bit if LPARRAY or SBSCRP are on and TOPLEV ∧¬[XWD EXTRNL,GLOBL].
03800 ⊗
03900
04000 ↑DCLINT: SKIPE A,GENLEF ; GET $TBITS VALUE IF DECLARED - ZERO
04100 MOVE A,$TBITS(A) ; OTHERWISE.
04200 TLNN A,SBSCRP ; TURN OFF OWN BIT IF LPARRAY OR SBSCRP AND
04300 TRNE A,LPARRAY ; TOPLEV ∧¬[XWD EXTRNL,GLOBL].
04400 TLNN FF,TOPLEV ;
04500 JRST MKINT1 ;
04600 TDNN A,[XWD EXTRNL,GLOBL] ;
04700 TLZ A,OWN ;
04800 MKINT1: TLZ FF,NOMACR ; TURN MACRO EXPANSION BACK ON
04900 MKINT2: PUSHJ P,CREINT ; CREATE INTEGER CONSTANT SEMBLK
05000 MOVEM PNT,GENRIG ; SET THE SEMANTIC STACK ENTRY TO
05100 ; THE SEMBLK ADDRESS OF THE NUMBER.
05200 POPJ P, ;
05300
05400
05500 DSCR SPRZER, XOWST1, VALST1, HELAR3, HELST1, TYPST1, RSTST1, MKINT
05600 PRO SPRZER, XOWST1, VALST1, HELAR3, HELST1, TYPST1, RSTST1, MKINT
05700 DES These routines are used to process the CHECK_TYPE command which takes as an
05800 argument a declaration and forms a word containing the apporopriate bits in
05900 SPRBTS.
06000 SPRZER Zeroes SPRBTS.
06100 XOWST1 Gets bits corresponding to @XO.
06200 VALST1 Gets bits corresponding to @VAL.
06300 HELAR3 Gets the LPARRAY bit.
06400 HELST1 Gets the ITEM or ITEMVAR bits.
06500 TYPST1 Gets the @ALGLP bit.
06600 RSTST1 Gets the remaining bits (i.e. PROCED, RES, BILTIN, DEFINE, SBSCRP, and
06700 LPARRAY for a LPARRAY declaration.
06800 MKINT Creates an integer out of the SPRBTS value and places it on the stack.
06900 ⊗
07000
07100 ↑SPRZER: SETZM SPRBTS ;
07200 SETOM NODFSW ; NO DEFINE TRIGGERING WHILE IN CHECK_TYPE.
07300 POPJ P, ;
07400
07500 ↑XOWST1: SKIPA A,XOTAB(B) ;
07600 ↑VALST1: MOVE A,VALTAB(B) ;
07700 JRST ENDFRM ;
07800
07900 ↑HELAR3: MOVEI A,LPARRAY ;
08000 IORM A,SPRBTS ;
08100 ↑HELST1:
08200 ↑TYPST1: SKIPA A,TYPTAB(B) ;
08300 ↑RSTST1: MOVE A,CHKTAB(B) ;
08400 ENDFRM: IORM A,SPRBTS ;
08500 POPJ P, ;
08600
08700 ↑MKINT: SETZM NODFSW ; ALLOW DEFINE TRIGGERING TO HAPPEN AGAIN.
08800 MOVE A,SPRBTS ;
08900 JRST MKINT2 ; MAKE AN INTEGER AND PLACE IT ON THE STACK.
09000
09100
09200 DSCR FFPUSH, FFPOP
09300 PRO FFPUSH, FFPOP
09400 DES These rotines are used to save and restore the DEFLUK bit of FF on a QSTACK
09500 pointed to by DEFDLM. This is necessary due to compile-time variables whose
09600 definition may cause other macros to be called. DEFLUK is used to indicate
09700 that a macro body is about to be scanned or a set of actual parameters to a
09800 macro are about to be scanned.
09900 FFPUSH Saves the DEFLUK bit of FF on a QSTACK pointed to by DEFDLM (actually save
10000 the entire value of FF).
10100 FFPOP Restores the DEFLUK bit of FF from the QSTACK pointed to by DEFDLM.
10200 ⊗
10300
10400 ↑FFPUSH: MOVEI LPSA,DEFDLM ; GET QSTACK POINTER
10500 MOVE A,FF ; A CONTAINS ITEM TO BE PUSHED IN QSTACK
10600 TLO FF,DEFLUK ; TURN ON DEFLUK BIT IN FF
10700 JRST BPUSH ; PUSH IN QSTACK
10800
10900 ↑FFPOP: MOVEI LPSA,DEFDLM ; GET STACK POINTER
11000 PUSHJ P,BPOP ; POP TOP OF QSTACK INTO A
11100 TLZ FF,DEFLUK ; RESTORE DEFLUK BIT OF FF TO PREVIOUS VALUE
11200 TLNE A,DEFLUK ;
11300 TLO FF,DEFLUK ;
11400 POPJ P, ;
11500
11600
11700 DSCR DLMPSH, DLMPOP
11800 PRO DLMPSH, DLMPOP
11900 DES These routines are used to save and restore the DEFLUK bit of FF and the value
12000 of the DLMSTG flag after encountering the DEFINE reserved word and after
12100 encountering the = sign in a macro definition. This is necessary so that macro
12200 names will be properly entered in the symbol table.
12300 DLMPSH Saves the current value of DLMSTG and sets it to zero. Also saves the
12400 current value of the DEFLUK bit of FF and sets it to zero.
12500 DLMPOP Restores the value of DLMSTG from the stack. Also restores the DEFLUK bit
12600 of FF.
12700 ⊗
12800
12900 ↑DLMPSH: QPUSH(LOKDLM,DLMSTG) ; SAVE DLMSTG
13000 SETZM DLMSTG ; DON'T LOOK FOR DELIMITED STRINGS
13100 MOVEI LPSA,DEFDLM ; GET STACK POINTER
13200 MOVE A,FF ;
13300 TLZ FF,DEFLUK ; STRINGS SCANNED IN NON-MACRO MODE
13400 JRST BPUSH ; PUSH IN QSTACK
13500
13600 ↑DLMPOP: QPOP(LOKDLM,DLMSTG) ; RESTORE DLMSTG
13700 JRST FFPOP ; RESTORE DEFLUK
13800
13900
14000 DSCR CPSHBT, CPOPBT, DPSHBT, DPOPBT
14100 PRO CPSHBT, CPOPBT, DPSHBT, DPOPBT
14200 DES These routines are used to save and restore bits before and after conditional
14300 compilation and macro definitions. This enables declarations to be interrupted
14400 without having the partially accumulated BITS value destroyed when expressions
14500 are looked up or string constants created.
14600 CPSHBT Saves current BITS value during conditional compilation.
14700 CPOPBT Restores the value of BITS after conditional compilation.
14800 DPSHBT Saves current BITS value during a macro definition.
14900 DPOPBT Restores the value of BITS after a macro definition.
15000 ⊗
15100
15200 ↑CPSHBT: QPUSH(CBTSTK,BITS) ;
15300 SETZM BITS ;
15400 POPJ P, ;
15500
15600 ↑CPOPBT: QPOP(CBTSTK,BITS) ;
15700 POPJ P, ;
15800
15900 ↑DPSHBT: QPUSH(DBTSTK,BITS) ;
16000 SETZM BITS ;
16100 POPJ P, ;
16200
16300 ↑DPOPBT: QPOP(DBTSTK,BITS) ;
16400 POPJ P, ;
16500
16600
16700 DSCR CPSHEN, CPSHEY, CPOPET
16800 PRO CPSHEN, CPSHEY, CPOPET
16900 DES These routines are used to allow parser switching in the bodies of WHILEC,
17000 CASEC, FORC, and FORLC statements. This enables one to conditionally compile
17100 these bodies. The routines serve to set and reset a flag which is kept in a
17200 QSTACK pointed at by ENDCTR. This flag indicates whether parser switching
17300 should occur when an ENDC is seen (i.e. if it is terminating a WHILEC, CASEC,
17400 FORC, or FORLC body, then no triggering should occur).
17500 CPSHEN Pushes a -1 on the QSTACK indicating that an ENDC seen with this value
17600 on top of the QSTACK is not to serve as a parser switching trigger.
17700 CPSHEY Pushes a zero on the QSTACK indicating that an ENDC seen with this value on
17800 the top of the QSTACK is to serve as a parser switching trigger.
17900 CPOPET Pops the QSTACK pointed to by ENDCTR when one is done with a particular
18000 ENDC parser switching trigger mode.
18100 ⊗
18200
18300 ↑CPSHEY: TDZA A,A ;
18400 ↑CPSHEN: SETOM A ;
18500 QPUSH(ENDCTR) ;
18600 POPJ P, ;
18700
18800 ↑CPOPET: QPOP(ENDCTR) ;
18900 POPJ P, ;
00100 DSCR LETSET, LETENT
00200 PRO LETSET LENENT
00300 DES EXECS for syntax
00400 LET ident=<reserved word>, .... , ... ;
00500 The semantics of the reserved word is copied into the identifier.
00600 This mechanism could be expanded to allow synonymating idents with
00700 characters, so that characters could be returned to the letter set,
00800 and to allow run-time expressions (LET FOO=1, FOO=FOO+1).
00900
01000 LTR: @IDD EXEC LETSET SCCAN 2 ¬LT1 #QCON
01100 LT1: SG = @RESERVED →→ EXEC LETENT SCAN ....
01200
01300 ⊗
01400 ↑LETSET: SETZM BITS ;NO BITS NOW
01500 PUSHJ P,ENTERS ;ENTER IT RANDOMLY
01600 SKIPN LPSA,NEWSYM ;BE CAREFUL
01700 ERR <DRYROT>
01800 MOVEM LPSA,GENRIG ;RESULT, SO TO SPEAK
01900 TLZ FF,NOMACR ;TURN OFF SPECIAL
02000 POPJ P, ;DONE
02100
02200
02300 ↑LETENT: SKIPE GENLEF
02400 ERR <SYNONYMS FOR RESERVED WORDS ONLY>
02500 MOVE TEMP,PARLEF ;BITS
02600 TLO TEMP,RES ;RESET RESERVED BIT
02700 MOVE PNT,GENLEF+2 ;NEW NAME FOR SAME THING
02800 MOVEM TEMP,$TBITS(PNT) ;MAKE THEM EQUIVALENT
02900 POPJ P, ;RETURN
03000
00100 DSCR TWCOND,SWICHP,SWPOFF,PSWICH,OKEOF
00200 PRO TWCOND SWICHP SWPOFF PSWICH OKEOF
00300 DES EXECS for conditional assembly
00400 TWCOND is responsible for indicating on the parse stack whether or not a
00500 condition is true. In the productions one assumes the condition
00600 is true, and thus if it is false then TWCOND will change the parse
00700 stack token to false.
00800 SWICHP switches parsers from the conditional parser back to the main sail
00900 parser. This entails saving the processor descriptor of the
01000 conditional parser (semantic stack pointer, parse stack pointer,
01100 production stack pointer, and number of calls to scanner that
01200 have still not yet been processed), as well as restoring the
01300 processor descriptor of the main sail parser.
01400 PSWICH does the reverse of SWICHP when one wants to switch from the main
01500 sail parser to the conditional parser. The actual code for this
01600 can be found in SYM at the end of the identifier scan routine.
01700 Note that this is not a procedure but it is described here for
01800 the sake of completeness.
01900 SWPOFF turns the switchparser switch (SWCPRS) off when one would want to
02000 switch to a parser that is already executing. This would typically
02100 happen when one has evaluated a condition to be false; since the
02200 conditional parser would now be in control and is in the process
02300 of swallowing characters until IFC ... ELSEC ... ENDC and nested
02400 occurrences are eliminated and an ENDC or ELSEC appears unnested.
02500 Thus what one has is a flag that says don't interrupt the con-
02600 ditional parser.
02700 OKEOF Is not strictly a part of conditional assembly. It was added to
02800 allow parser to see EOF as a token on some occasions. This allows
02900 code after DONES to scan to EOF, listing rest of file (final END
03000 bug). Will also lead the way to more parsers, like the conditional
03100 parser. OKEOF simply turns on SCNWRD's EOFOK bit...SCANNER
03200 then returns EOF token when appropriate.
03300 ⊗
03400 ↑TWCOND: GETSEM (1) ; GET SEMANTICS OF ARITHMETIC EXPRESSION
03500 MOVE TEMP,%CFLS1 ; ASSUME COMPARE FALSE (0 OR NOT CONSTANT)
03600 TLNE TBITS,CNST ; CONSTANT?
03700 SKIPN $VAL(PNT) ; ZERO?
03800 MOVEM TEMP,PARRIG ; YES, CHANGE FROM CTRU1 TO CFLS1
03900 POPJ P, ; RETURN
04000
04100
04200 ↑SWPOFF: SETZM SWCPRS ; TURN OFF SWITCH PARSEERS FLAG
04300 POPJ P, ; RETURN
04400
04500 ↑OKEOF: MOVE TEMP,SCNWRD ;TURN ON EOFOK FOR SCANNER (SCANNER ALWAYS
04600 TLO TEMP,EOFOK ; TURNS IT OFF, SO PRODUCTIONS MUST TURN
04700 MOVEM TEMP,SCNWRD ; IT ON EACH TIME (PROBABLY NOT NECESSARY,
04800 POPJ P, ; BUT SCANNER SOMETIMES HAS TO TURN IT OFF
04900 ; UNDER CURRENT IMPL, SO...)
05000
05100 ↑SETFL: MOVE LPSA,GENLEF+2 ; MACRO PSEUDONYM SEMBLK
05200 MOVE LPSA,$VAL2(LPSA) ; ADDRES OF ACTUAL PARAMETER RING SEMBLK
05300 MOVEM LPSA,DEFRN2 ; STORE IT IN DEFRN2
05400 JRST SETFL1 ; GO CONTINUE PREPARING FOR A MACRO CALL
05500
05600 ↑SETFR: MOVE LPSA,GENLEF+2 ; GET MACRO PSEUDONYM SEMBLK
05700 PUSHJ P,MKFRLP ; MAKE A FORC LOOP PARAMETER (I.E. LOOP VAR)
05800 POP SP,PNAME+1 ; SECOND WORD OF STRING DESCRIPTOR
05900 POP SP,PNAME ; FIRST WORD OF STRING DESCRIPTOR
06000 EXCH SP,STPSAV ; RETURN STRING POINTER (EXCH IN MKFRLP)
06100 PUSH P,VARB ; SAVE VARB AND SET IT TO ZERO SO ENTERS
06200 SETZM VARB ; WILL LINK AS IF ACTUAL MACRO PARAMETER
06300 TLO FF,PRMSCN ; SET GOOD BITS
06400 PUSHJ P,FFPUSH ; SAVE DEFLUK BIT OF FF AND TURN IT ON IN FF
06500 PUSH P,BITS ; SAVE THESE
06600 MOVE B,[XWD CNST,STRING] ; STRING CONSTANT
06700 MOVEM B,BITS ; PREPARE FOR ENTERS
06800 MOVE LPSA,STRCON ; BUCKET SEMBLK FOR SHASH
06900 PUSHJ P,SHASH ; GET HASH BUCKET
07000 PUSHJ P,ENTERS
07100 MOVE TEMP,NEWSYM ; GET PARAMETER SEMBLK
07200 MOVEM TEMP,DEFRN2 ; SET UP ACTUAL PARAMETER RING
07300 POP P,BITS ; RESTORE BITS
07400 POP P,VARB ; RESTORE VARB
07500 TLZ FF,PRMSCN ; RESET GOOD BITS
07600 PUSHJ P,FFPOP ; RESTORE DEFLUK BIT IN FF
07700 SETFL1: EXCH SP,STPSAV ; GET STRING POINTER
07800 MOVE TEMP,GENLEF+1 ; GET FORC OR FORLC BODY STRING SEMBLK
07900 PUSH SP,$PNAME(TEMP) ; FIRST WORD OF STRING DESCRIPTOR
08000 PUSH SP,$PNAME+1(TEMP) ; SECOND WORD OF STRING DESCRIPTOR
08100 PUSHJ P,CTENDC ; APPEND COND COMP ENDING (" ENCD 177 0")
08200 MOVE LPSA,GENLEF+2 ; LPSA MUST CONTAIN MACRO PSEUDONYM SEMBLK
08300 JRST PRCAL1 ; GO CONTINUE PREPARING FOR A MACRO CALL
08400
08500 ↑SETCSE: EXCH SP,STPSAV ; GET STRING POINTER
08600 MOVE TEMP,GENLEF+1 ; GET THE CASEC BODY STRING SEMBLK
08700 PUSH SP,$PNAME(TEMP) ; FIRST WORD OF STRING DESCRIPTOR
08800 PUSH SP,$PNAME+1(TEMP) ; SECOND WORD OF STRING DESCRIPTOR
08900 PUSHJ P,CTENDC ; APPEND COND COMP ENDING (" ENDC 177 0")
09000 MOVE LPSA,GENLEF+3 ; LPSA MUST CONTAIN MACRO PSEUDONYM SEMBLK
09100 JRST PRECAL ; GO CONTINUE PREPARING FOR A MACRO CALL
09200
00100
00200 ↑SETWHL: EXCH SP,STPSAV ; GET STRING POINTER
00300 PUSH SP,[XWD 0,4] ; LENGTH OF FOLLOWING STRING
00400 PUSH SP,[POINT 7,[ASCII "IFC "]] ; FIRST WORD OF PSEUDO MACRO
00500 MOVE TEMP,GENLEF+3 ; GET THE CONDITION STRING SEMBLK
00600 PUSH SP,$PNAME(TEMP) ; FIRST WORD OF STRING DESCRIPTOR
00700 PUSH SP,$PNAME+1(TEMP) ; SECOND WORD OF STRING DESCRIPTOR
00800 PUSHJ P,CAT ; CONCATENATE
00900 PUSH SP,[XWD 0,7] ; LENGTH OF FOLLOWING STRING
01000 PUSH SP,[POINT 7,[ASCII " THENC "]] ; END OF CONDITION
01100 PUSHJ P,CAT ; CONCATENATE
01200 FREBLK GENLEF+3 ; FREE THE CONDITIONS SEMBLK
01300 MOVE TEMP,GENLEF+1 ; GET THE PSEUDO MACRO BODY STRING SEMBLK
01400 PUSH SP,$PNAME(TEMP) ; FIRST WORD OF STRING DESCRIPTOR
01500 PUSH SP,$PNAME+1(TEMP) ; SECOND WORD OF STRING DESCRIPTOR
01600 PUSHJ P,CAT ; CONCATENATE
01700 PUSHJ P,CTENDC ; APPEND COND COMP ENDING (" ENDC 177 0")
01800 MOVE LPSA,GENLEF+2 ; LPSA MUST CONTAIN MACRO PSEUDONYM SEMBLK
01900 PRECAL: SETZM DEFRN2 ; WHILEC AND CASEC HAVE NO PARAMETER RINGS
02000 PRCAL1: HLRZ TEMP,%TLINK(LPSA) ; SEMBLK OF PSEUDO MACRO BODY
02100 POP SP,$PNAME+1(TEMP) ; FIRST WORD OF STRING DESCRIPTOR
02200 POP SP,$PNAME(TEMP) ; SECOND WORD OF STRING DESCRIPTOR
02300 EXCH SP,STPSAV ; RETURN STRING POINTER
02400 MOVE TBITS2,SCNWRD ; SYNCH SCAN COMTROL WORD
02500 JRST ACPMED ; GO PREPARE FOR A MACRO CALL (IN SCANNER)
02600
02700 ↑CTENDC: PUSH SP,[XWD 0,8] ; LENGTH OF FOLLOWING STRING
02800 PUSH SP,[POINT 7,[BYTE (7) " ","E","N","D","C"," ",177,0]] ; END
02900 ; OF PSEUDO MACRO BODY
03000 JRST CAT ; CONCATENATE
03100
03200 ↑SWICHM: MOVE LPSA,GENLEF+2 ; PSEUDO MACRO NAME SEMBLK
03300 JRST CONTXT ; PREPARE FOR WHILEC BODY SCAN
03400
03500 ↑SWCHFR: MOVE LPSA,GENLEF ; PSEUDO MACRO NAME SEMBLK
03600 PUSHJ P,MKFRLP ; GET NEW FORC LOOP PARAMETER
03700 MOVE LPSA,DEFRNG ; SEMBLK OF PSEUDO MACRO PARAMETER
03800 POP SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
03900 POP SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR
04000 EXCH SP,STPSAV ; RETURN STRING POINTER (EXCH IN MKFRLP)
04100 ↑SWCHFL: MOVE LPSA,GENLEF ; PSEUDO MACRO NAME SEMBLK
04200 JRST CONTXT ; PREPARE FOR FORC OR FORLC BODY SCAN
04300
04400 ↑MKFRLP: EXCH SP,STPSAV ; GET STRING POINTER
04500 PUSH P,$VAL2(LPSA) ; CURRENT VALUE OF FORC LOOP PARAMETER
04600 PUSHJ P,CVS ; CONVERT TO STRING
04700 PUSH SP,[XWD 0,2] ; LENGTH OF FOLLOWING STRING
04800 PUSH SP,[POINT 7,[BYTE (7) 177,0]] ; MACRO PARAMETER ENDING
04900 JRST CAT ; CONCATENATE
05000
05100 ↑GTSTRT: PUSHJ P,GETCVI ; CONVERT FORC STARTING VALUE TO INTEGER
05200 MOVEM PNT,$VAL2(LPSA) ; STORE IN $VAL2 OF MACRO PSEUDONYM SEMBLK
05300 POPJ P, ; RETURN
05400
05500 ↑GTSTEP: PUSHJ P,GETCVI ; CONVERT FORC STEP TO INTEGER
05600 MOVEM PNT,$DATA(LPSA) ; STORE IN $DATA OF MACRO PSEUDONYM SEMBLK
05700 POPJ P, ; RETURN
05800
05900 ↑GETERM: PUSHJ P,GETCVI ; CONVERT FORC END VALUE TO INTEGER
06000 MOVE LPSA,GENLEF+2 ; SEMANTICS OF MACRO PSEUDONYM
06100 MOVEM PNT,$DATA2(LPSA) ; STORE IN $DATA2 OF MACRO PSEUDONYM SEMBLK
06200 MOVE PNT,$VAL2(LPSA) ; GET FORC STARTING VALUE
06300 PUSHJ P,TWNUM1 ; GO CHECK IF STARTING VALUE IS OUT OF RANGE
06400 CAMN PNT,%CFLS1 ; STARTING VALUE OUT OF RANGE?
06500 PUSHJ P,FFPUSH ; NO
06600 POPJ P, ; RETURN
06700
06800 ↑GETCVI: MOVE PNT,GENLEF+1 ; STRING SEMBLK TO BE CONVERTED TO INTEGER
06900 GENMOV(CONV,INSIST!GETD,INTEGR) ; CONVERT
07000 MOVE PNT,$VAL(PNT) ; GET INTEGER VALUE
07100 MOVE LPSA,GENLEF+2 ; ADDRESS OF MACRO PSEUDONYM SEMBLK
07200 POPJ P, ; RETURN
07300
07400 ↑TWNUM: MOVE LPSA,GENLEF+1 ; ADDRESS OF FORC MACRO PSEUDONYM SEMBLK
07500 MOVE PNT,$DATA(LPSA) ; FORC LOOP STEP VALUE
07600 ADDB PNT,$VAL2(LPSA) ; INCREMENT CURRENT FORC LOOP VALUE
07700 ↑TWNUM1: SUB PNT,$DATA2(LPSA) ; SUBTRACT FORC LOOP END VALUE
07800 SKIPL $DATA(LPSA) ; STEP NEGATIVE?
07900 MOVN PNT,PNT ; NO, NEGATE STEP
08000 JUMPGE PNT,GPOPJ ; DONE WITH LOOP IF POSITIVE
08100 MOVE PNT,%CFLS1 ; TWIDDLE TO INDICATE END OF FORC LOOP
08200 MOVEM PNT,PARRIG+1 ; SET PARSE STACK TO TWIDDLED VALUE
08300 GPOPJ: POPJ P, ; RETURN
08400
08500 ↑GETACT: MOVE LPSA,GENLEF+2 ; ADDRESS OF FORLC MACRO PSEUDONYM SEMBLK
08600 HRLZI TEMP,1 ; SET PARAMETER COUNT TO ZERO
08700 MOVEM TEMP,$VAL(LPSA) ; STORE IT (incredibly imaginative comment)
08800 MOVE TBITS2,SCNWRD ; SYNCH SCAN CONTROL WORD
08900 PUSHJ P,SCNACT ; SCAN A LIST OF ACTUAL PARAMETERS WHICH
09000 ; CAN HAVE A SPECIAL DELIMITER DECLARATION
09100 ; (IN SCANNER)
09200 MOVE TEMP,DEFRN2 ; DEFRN2 POINTS TO RING OF ACTUAL PARAMETERS
09300 MOVEM TEMP,$VAL2(LPSA) ; STORE IT IN $VAL2 OF FORLC MACRO PSEUDO-
09400 ; NYM SEMBLK SO THAT THE MACRO BODY CAN BE
09500 ; PROPERLY SCANNED FOR PARAMETER SUBSTITU-
09600 ; TIONS
09700 POPJ P, ; RETURN
09800
09900 ↑TWACT: MOVE LPSA,DEFRNG ; GET FORLC ACTUAL PARAMETER RING
10000 HRRZ LPSA,%RVARB(LPSA) ; GET NEXT PARAMETER IF NOT DONE
10100 JUMPN LPSA,.+4 ; FORLC ACTUAL PARAMETER LIST EXHAUSTED
10200 MOVE LPSA,%CFLS1 ; TOKEN TO BE TWIDDLED
10300 MOVEM LPSA,PARRIG+1 ; SET PARSE STACK STRAIGHT
10400 POPJ P, ; RETURN
10500 FREBLK DEFRNG ; FREE PREVIOUS PARAMETER SEMBLK
10600 MOVEM LPSA,DEFRNG ; SET DEFRNG TO CURRENT ACTUAL PARAMETER
10700 POPJ P, ; RETURN
10800
10900 ↑TWCSCN: MOVE TEMP,GENLEF+3 ; ADDRESS OF CASEC MACRO PSEUDONYM SEMBLK
11000 SOSE $VAL2(TEMP) ; RIGHT CASEC?
11100 POPJ P, ; NO, RETURN
11200 PUSHJ P,CPSHEN ; SET ENDC DOESN'T TRIGGER A PARSER SWITCH FLAG
11300 SETOM SWCPRS ; PARSER SWITCHING IS OK (I.E. IFC IN BODY OF CASEC
11400 ; TO BE EXECUTED)
11500 MOVE TEMP,%CTRU1 ; TWIDDLE SO NEXT CASEC WILL BE SCANNED
11600 MOVEM TEMP,PARRIG ; SET PARSE STACK STRAIGHT
11700 POPJ P, ; RETURN
11800
11900 ↑FREMBN: MOVE A,GENLEF+2 ; GET RID OF FORMAL PARAMETER LIST TO FORC
12000 MOVE LPSA,$ACNO(A) ; AND FORLC WHICH ARE NEVER EXECUTED AS
12100 PUSHJ P,KILLST ; WELL AS RESTORE THE PROPER LEVEL AND
12200 MOVE LPSA,GENLEF+2 ; VARB
12300 PUSHJ P,CLENUP ;
12400 JRST FRMBFF ;
12500 ↑FREMBF:SKIPA LPSA,GENLEF ; FORC, AND FORLC MACRO PSEUDONYM
12600 ↑FREMBW: MOVE LPSA,GENLEF+2 ; WHILEC MACRO PSEUDONYM
12700 ; SEMBLK ADDRESS
12800 FRMBFF: HLRZ TEMP,%TLINK(LPSA) ; PSEUDO MACRO BODY SEMBLK ADDRESS
12900 FREBLK TEMP ; FREE THE PSEUDO MACRO BODY SEMBLK
13000 FREBLK ; FREE THE MACRO PSEUDONYM SEMBLK
13100 POPJ P, ; RETURN
13200
13300 ↑FRMBCE: PUSHJ P,FRMBCF ; DELETE SEMBLK OF BODY OF LAST FALSE CASEC
13400 MOVE LPSA,GENLEF+3 ; CASEC SEMBLK ADDRESS
13500 SKIPLE $VAL2(LPSA) ; CHECK IF NONE OF THE CASEC CASES WERE
13600 PUSHJ P,CLENUP ; EXECUTED; IF SO RESTORE VARB AND LEVEL
13700 FREBLK GENLEF+3 ; DELETE CASEC PSEUDONYM SEMBLK
13800 POPJ P, ; RETURN
13900
14000 ↑FRMBCF: GETSEM(1) ; GET SEMANTICS OF LAST FALSE CASEC
14100 TRNN TBITS,STRING ; DON'T DELETE IF NOT A STRING SINCE A CVS
14200 ; IS ONLY DONE FOR TRUE CASEC (IN DFENT)
14300 ; OTHERWISE A GOOD CONSTANT MAY BE DELETED
14400 POPJ P, ; NOT A STRING, RETURN
14500 FREBLK GENLEF+1 ; DELETE SEMBLK OF BODY OF LAST FALSE CASEC
14600 POPJ P, ; RETURN
14700
14800 ↑FRMBCT: MOVE LPSA,GENLEF+2 ; LAST TRUE CASEC BODY SEMBLK
14900 HLRZ TEMP,%TLINK(LPSA) ; LAST TRUE CASEC BODY SEMBLK
15000 FREBLK TEMP ; DELETE SEMBLK OF BODY OF LAST TRUE CASEC
15100 HRRZS %TLINK(LPSA) ; MACRO PSEUDONYM NO LONGER HAS A BODY LINK
15200 POPJ P, ; RETURN
15300
15400 CLENUP: MOVE TEMP,$ADR(LPSA) ; RESTORE VARB AND LEVEL WHEN CASEC, FORC,
15500 MOVEM TEMP,VARB ; AND FORLC ARE NOT EXECUTED. EXPECTS
15600 SOS LEVEL ; LPSA TO CONTAIN THE ADDRESS OF THE
15700 JRST FREBUK ; RELEVANT SEMBLK
15800
15900 ↑TMACIN: SKIPE PRSCON ; DETERMINE WHICH PARSER IS CURRENTLY SUSPENDED AND
16000 SKIPA A,SSCWSV ; GET A POINTER TO ITS SCNWRD STACK. THIS IS USED
16100 MOVE A,CSCWSV ; TO SET THE MACIN BIT IN SYNCH WITH MACROS THAT
16200 POPJ P, ; MIGHT HAVE ENDED WHILE THE SUSPENDED OR MOST
16300 ; RECENTLY ACTIVATED PARSER WERE INACTIVE.
16400
16500 ↑TOMACN: PUSHJ P,TMACIN ; CHANGE MACIN BIT OF PARSER TO BE RESUMED TO
16600 LDB TBITS2,[POINT 1,SCNWRD,6] ; THE VALUE OF THE MACIN BIT OF THE
16700 DPB TBITS2,[POINT 1,(A),6] ; CURRENT PARSER.
16800 POPJ P, ;
16900
17000 ↑FRMACN: PUSHJ P,TMACIN ; CHANGE THE MACIN BIT OF THE CURRENT PARSER TO
17100 LDB TBITS2,[POINT 1,(A),6] ; THE VALUE OF THE MACIN BIT OF THE SUSPENDED
17200 DPB TBITS2,[POINT 1,SCNWRD,6] ; PARSER.
17300 POPJ P, ;
00100 SUBTTL EXECS for Entry Declaration
00200 DSCR ENTMAK, ENTOUT
00300 PRO ENTMAK ENTOUT
00400 DES EXECS for syntax
00500 ENTRY id1, id2, ...., ... ;
00600 Must appear before initial BEGIN
00700 SEE comment below DSCR for details
00800 ⊗
00900
01000 Comment ⊗ ENTRY code -- has two functions:
01100 1. Denote that this compilation is not the main program
01200 but a collection of separately compiled procedures.
01300 2. Create an entry block so that these programs
01400 can be loaded from a library.
01500
01600 The syntax:
01700
01800 BB0: ENTRY → SCAN 2 ¬ ENT
01900 BEGIN → BLAT BEGIN EXEC ENTOUT DWN SCAN ¬DS
02000
02100 ...
02200
02300 ENT: @I , → EXEC ENTMAK SCAN 2 ¬ ENT
02400 @I ; → EXEC ENTMAK SCAN ¬ BB0
02500
02600 ⊗
02700
02800 NOGAG <
02900 ↑ENTMAK: TLZE FF,MAINPG ;NO STARTING ADDRESS FOR THIS PROGRAM
03000 HLLZS ENTTAB ;RESET FIRST TIME IN
03100 HRL LPSA,PNAME ;COUNT
03200 HRR LPSA,PNAME+1 ;BYTE POINTER FOR ENTRY SYMBOL
03300 PUSHJ P,RAD52 ;MAKE RADIX50 FOR ENTRY
03400 AOS B,ENTTAB ; → NEXT ENTRY
03500 HRRZS B ;CLEAR LEFT HALF
03600 MOVEM A,ENTTAB+1(B) ;TO ENTRY TABLE
03700 CAIGE B,22 ;FULL?
03800 POPJ P, ;NO
03900
04000 ↑ENTOUT:
04100 MOVEI B,ENTTAB ;PUT OUT BLOCK IF THERE IS
04200 TLNN FF,MAINPG ; ONE
04300 JRST GBOUT
04400 POPJ P, ;THERE IS NONE FOR SURE
04500
04600 >;NOGAG
04700 GAG<
04800 ↑ENTMAK:
04900 ↑ENTOUT:
05000 POPJ P, ;NO WAY IN "GOGOL"
05100 >;GAG
05200
05300 SUBTTL EXECS for Storage Allocation at end of Procedure
05400
00100 DSCR ALOT
00200 DES Allocation routine -- called by PRUP and DONES EXECS, allocates
00300 storage, issues fixups and symbols for all locals in Procedure
00400 (outer Block)
00500 PAR VARB-rings on BLKLIS Qstack
00600 RES ALIMS, ALOCALS, SLIMS, SLOCALS, LLIMS, LLOCALS as described
00700 in subsequent comments
00800 SEE comment below DSCR for details
00900 ⊗
01000
01100 COMMENT ⊗
01200 This is the code invoked to allocate space for variables on the
01300 VARB ring. Symbols are also output to the loader, for use by DDT and
01400 the world. As each block is closed, the portion of the VARB ring developed
01500 for that block is saved by a pointer in the table BLKLIS, and the count
01600 BLKIDX is incremented. It is the job of this code to run through all
01700 the VARB information stored on this list, and allocate.
01800
01900 There is a bit in FF, called ALLOCT which determines whether
02000 this code actually allocates storage, or merely counts things.
02100 The counts are necessary for deciding how exit and entry code for
02200 recursive procedures should be generated. These counts are:
02300 ALOCAL (arithmetic stack locals) and SLOCAL (string stack
02400 locals). FIRSYM and LSTSYM point to the first and last symbols allocated.
02500
02600 ⊗
02700 ZERODATA (VARIABLE-ALLOCATION VARIABLES)
02800
02900 COMMENT ⊗
03000 ALIMS -- [Semantics of last,Semantics of first] -- set up by ALLOT
03100 to indicate the range of non-string variables allocated. This
03200 is used by PROCED after the first (non-allocating) call on ALLOT
03300 and before the second (allocating) call, to set up saving
03400 and restoring instructions (BLT) for these variables for
03500 recursive Procedures. The non-allocating run allows these extra
03600 instructions to be inserted before fixed locations are assigned
03700 to the variables (see ALLOT's DSCRs).
03800 ⊗
03900 ↑↑ALIMS: 0
04000
04100 ;ALOCALS -- a count of the number of non-string locals -- set up
04200 ; for the same reasons given above for ALIMS
04300 ↑↑ALOCALS: 0
04400
04500 ;BLKCNT -- temp used when outputing symbol names -- see DOSYM's
04600 ; DSCR for details
04700 ↓BLKCNT: 0
04800
04900 ;FIRSYM -- Semantics of first variable allocated by ALOT -- used to
05000 ; set up ALIMS, SLIMS, LLIMS
05100 ↓FIRSYM: 0
05200
05300 ;LLIMS -- ALIMS-like thing for sets -- ALIMS includes LLIMS in its
05400 ; range -- used to put together Set Link Blocks -- see ALLOT
05500 ↓LLIMS: 0
05600
05700 ;LLOCAL -- ALOCAL-type count of number of Sets this Procedure
05800 ↓LLOCAL: 0
05900
06000 ;LSTSYM -- Semantics of last variable allocated by ALOT -- used to
06100 ; set up ALIMS, SLIMS, LLIMS
06200 ↓LSTSYM: 0
06300
06400 ;SLIMS -- ALIMS-like thing for strings. Used for above-
06500 ; mentioned purposes; also to put together String Link Blocks
06600 ; See ALLOT, LNKOUT
06700 ↑↑SLIMS: 0
06800
06900 ;SLOCALS -- ALOCALS-type count for # Strings this Procedure
07000 ↑↑SLOCALS: 0
07100
07200 THSLVL: 0
07300 ENDDATA
07400
00100 ↑ALOT: ;ROUTINE TO HANDLE ALLOCATION
00200 ;OF CORE AND THINGS FOR VARIABLES.
00300 SETZM FIRSYM
00400 TLNN FF,ALLOCT ;ALLOCATING REALLY?
00500 JRST ALSYMS ; NO, IGNORE ADCONS THIS TIME AROUND
00600
00700 ;ALLOCATE ADDRESS CONSTANTS. INFORMATION ABOUT THEM IS
00800 ;SAVED ON THE VARB RING HOMED AT ADRTAB. SEE PROCED
00900 ;FOR DETAILS OF HOW THE ADDRESS CONSTANTS ARE USED.
01000
01100 ADCGO: HRRZ LPSA,TPROC ;GET LEVEL OF PROCEDURE WHOSE LOCALS
01200 LDB TEMP,PLEVEL ; ARE BEING DEFINED
01300 MOVEM TEMP,THSLVL
01400 HRRZ LPSA,ADRTAB ;ADDRESS CONSTANTS.
01500 JUMPE LPSA,ALSYMS ;NONE
01600
01700 RADA: MOVE SBITS,$SBITS(LPSA) ;IF A TEMP, IT IS IDENTIFIED BY
01800 TLNN SBITS,ARTEMP ;ITS SEQUENCE NO, ELSE BY SEMANTIC ADR
01900 JRST RADAA ;NOT A TEMP
02000
02100 MOVE A,$PNAME(LPSA) ;THE ID NO FOR THIS TEMP
02200 MOVE PNT,TTEMP ;SEARCH THE TEMP LIST FOR IT
02300 RADLP: JUMPE PNT,NOUNLK ;NOT THERE, TRY LATER
02400 CAMN A,$PNAME(PNT) ;IS THIS THE RIGHT INFO?
02500 JRST RADAB ; YES, PUT OUT ADCON
02600 HLRZ PNT,%RVARB(PNT) ;NO, KEEP LOOKING
02700 JRST RADLP
02800
02900 RADAA: HLRZ PNT,%TLINK(LPSA) ;GET POINTER TO
03000 RADAB: PUSHJ P,GETAD ;SEMANTICS OF SYMBOL WHOSE AD IS CONED.
03100 TLNE SBITS,CORTMP ;IS THIS A CORE TEMP?
03200 JRST OKRADA ; YES, PUT OUT THE ADCON
03300 TLNE SBITS,ARTEMP
03400 ; ***** BUG TRAP
03500 ERR <DRYROT -- RADA>,1
03600 TLNE TBITS,CNST
03700 JRST OKRADA ;EACH WILL APPEAR BUT ONCE
03800 TDZ SBITS,[¬LLFLDM] ;GET LEVEL ONLY
03900 CAMGE SBITS,THSLVL ;IF ADCON CORRESPONDS TO
04000 JRST NOUNLK ;SOMETHING IN THIS PROC, PUT IT OUT
04100
04200 OKRADA:
04300 NOGAG <
04400 HRLZ B,$ADR(LPSA) ;ADCON FIXUP
04500 JUMPE B,RADC ;WAS NOT USED.
04600 HRR B,PCNT
04700 PUSHJ P,FBOUT ;FIXUP FOR THE ADCON.
04800 HLL A,$ADR(LPSA) ;TYPE BITS TO INSERT.
04900 HRRI A,FXTWO!NOUSAC
05000 TLNN TBITS,SBSCRP ;IF ¬SBSCRP ∧ STRING,
05100 TRNN TBITS,STRING ; USE 2D WORD FIXUP
05200 TRZ A,FXTWO ;ELSE REGULAR OLD FIXUP
05300 PUSHJ P,EMITER ;USE HIM TO OUTPUT THE WORD.
05400 >;NOGAG
05500 RADC: PUSHJ P,URGADR ;REMOVE FROM ADRTAB
05600 FREBLK (LPSA)
05700 NOUNLK: LEFT ,%RVARB,ALSYMS ;LOOP UNTIL DONE.
05800 JRST RADA
05900
06000
00100
00200 Comment ⊗
00300 NOW ALLOCATE STORAGE FOR VARIABLES.
00400
00500 When a block has been compiled, the pointer to its block entry (and thus to
00600 its VARB ring of locals) is placed in the next free location in BLKLIS
00700 (using BLKIDX QPDP). BLKIDX is cleared at the beginning of each procedure
00800 compilation, and the old value is stored. In all that follows, all and only
00900 those blocks whose pointers lie in the current BLKLIS will be processed.
01000
01100 In order to keep things together for BLT'ing on and off the stacks, strings
01200 are allocated first. Then arrays. Then all else. The routine "ALLO" is
01300 called to actually look for things to allocate. It uses the mask set up in
01400 TBITS2.
01500
01600 ⊗
01700
01800 ALSYMS: MOVEI TBITS2,STRING ;FIRST ALLOCATE STRINGS.
01900 REN <
02000 PUSHJ P,LOSET ;SWITCH TO DATA SEGMENT
02100 >;REN
02200 DIS <
02300 SETZM CSPOS ;SET STACK DISPL=0
02400 >;DIS
02500 PUSHJ P,ALLO ;GO DO IT.
02600 LSH PNT2,1
02700 MOVEM PNT2,SLOCAL ;SAVE COUNT OF STRINGS ALLOCATED.
02800 MOVEM A,SLIMS ;LIMITS OF SYMBOLS.FOR STRINGS
02900 DIS <
03000 MOVE PNT2,CSPOS ;
03100 MOVEM PNT2,SSDIS ;STRING STACK DISPL DUE TO LOCALS
03200 MOVEI PNT2,2 ;FOR MCSP SIZE
03300 SKIPE SIMPSW ;IF SIMPLE
03400 HRRZI PNT2,0 ;THEN NO MSCP
03500 MOVEM PNT2,CSPOS ;SET CNTR
03600 >;DIS
03700 AL1: SETZM FIRSYM
03800 SETZM LSTSYM
03900 MOVEI TBITS2,SET!LSTBIT ;ALLOCATE SETS FIRST AMONG "ARITHMETICS"
04000 PUSHJ P,ALLO
04100 HRLZM PNT2,LLOCAL ;FOR SETS ONLY.
04200 MOVEM A,LLIMS
04300 MOVEM PNT2,ALOCAL ;START LOCAL COUNT FOR ARITHS.
04400 MOVSI TBITS2,SBSCRP ;ALLOCATE ARRAYS.
04500 PUSHJ P,ALLO
04600 ADDM PNT2,ALOCAL ;COUNT OF ARITH. LOCALS.
04700 MOVEI TBITS2,-1 ≠ (STRING!LSTBIT!SET) ;ALL OTHERS.
04800 PUSHJ P,ALLO
04900 ADDM PNT2,ALOCAL ;AND UPDATE LOCAL COUNT
05000 PUSHJ P,TMPALO ;ALLOCATE TEMPS.
05100 ADDM PNT2,ALOCAL ;AND UPDATE LOCAL COUNT
05200 MOVE A,FIRSYM
05300 HRL A,LSTSYM
05400 MOVEM A,ALIMS ;LIMITS OF ARITH. LOCALS.
05500 DIS <
05600 MOVE PNT2,CSPOS ;PICK UP STACK LOC
05700 MOVEM PNT2,ASDIS ;SAVE IT AS ARITH STACK DISPL FOR LOCALS
05800 >;DIS
05900 REN <
06000 PUSHJ P,HISET ;BACK TO CODE SEGMENT
06100 >;REN
06200 TLNN FF,ALLOCT ;ACTUALLY ALLOCATING ?
06300 POPJ P, ;NO -- DONE COMPLETELY.
06400
06500 DIS <
06600 HRRZ PNT2,TPROC ;THIS PROCEDURE
06700 SKIPN SIMPSW ;IF SIMPLE, NO PD
06800 PUSHJ P,PDOUT ;PUT OUT PROC DESC
06900 >;DIS
07000
07100 AL2: SETZM TTEMP ;RESTART TEMP LIST.
07200 SETZM BLKCNT ;NO BLOCKS LOOKED AT OR ALLOCATED
07300 QBEGIN (BLKIDX) ;FIND BOTTOM ELEMENT IN BLKLIM QSTACK
07400 JUMPE B,CRECHK ; NO SYMBOLS TO ALLOCATE
07500
00100 Comment ⊗
00200
00300 ; NOW ISSUE SYMBOLS FOR THIS PROCEDURE
00400
00500 At procedure declaration, and at the beginning of each NAMED block or
00600 compound statement, a count called NMLVL (name level) is incremented. Its
00700 current value is stored in $VAL2 of every block and NAMED compound
00800 statement. It is also stored in procedure blocks. It is decremented at
00900 appropriate times.
01000
01100 When a block pointer is placed in BLKLIS (via BLKIDX QPDP), its left half
01200 is 0 if the block has a name, -1 otherwise (depends on higher-LEVELed block
01300 for name). A non-named block's NMLVL should be the same as that of the
01400 next named block in the list.
01500
01600 Inner blocks appear in BLKLIS preceding outer ones. DDT (as it happens)
01700 requires that symbols for inner blocks appear first. So the algorithm for
01800 symbol allocation is:
01900
02000 1) Search from BLKLIS bottom to 1st named Block (index→SBITS2)
02100 2) Put out Block name and level to .REL file
02200 3) NMLVL of this block to TBITS2
02300 4) For each BLKLIS entry from current backwards to bottom,
02400 or until an entry is found whose NMLVL is lower (outer block)
02500 that TBITS2, if the Block hasn't been handled (list entry 0),
02600 include its symbols in this DDT block on the .REL file.
02700 5) Search forwards for the next named block (index → SBITS2).
02800 If one is found, go to step 2.
02900 6) If some blocks were not handled, it is because the outer block of
03000 this procedure was not named. Put out procedure name as block name,
03100 and repeat step 3 once more to get the rest of the symbols.
03200 7) Reset BLKIDX QPDP
03300 ⊗
03400
03500 ;STEP 1,5 -- FORWARDS SEARCH LOOP
03600 DOSYM: MOVEM B,SBITS2 ;B GETS CHANGED BY DOSYL1
03700 DOSYML: MOVE B,SBITS2 ;GET QSTACK PDP FOR FORWARD SEARCH
03800 QTAKE (BLKIDX) ;LOOK AT NEXT BLOCK
03900 JRST DIDSYM ; HAVE LOOKED AT ALL, CHECK FOR REMAINING
04000 AOS BLKCNT ;ADD ONE FOR EACH ONE GLIMPSED
04100 MOVEM B,SBITS2 ;PROTECT THIS QPDP
04200 JUMPLE A,DOSYML ;IF NOT NAMED, CONTINUE FORWARD SEARCH
04300 MOVE LPSA,A
04400 ;STEP 2
04500 PUSHJ P,BLBOUT ;ISSUE BLOCK NAME TO .REL FILE
04600 ;STEP 3
04700 HRRZ TBITS2,$VAL2(LPSA) ;NMLVL (DDT LEVEL) OF THIS BLOCK
04800 MOVE B,SBITS2 ;BLBOUT CHANGES, MAYBE
04900
05000 ;STEP4 -- BACKWARDS SEARCH LOOP
05100 DOSYL1: QBACK ;NONDESTRUCTIVE POP
05200 JRST DOSYML ; HAVE ALL BLOCKS, RETURN TO FORWARD SEARCH
05300 JUMPE A,DOSYL1 ;ALREADY DID THIS ONE
05400 MOVE LPSA,A ;BELONGS HERE FOR NOSY ETC.
05500 HRRZ TEMP,$VAL2(LPSA);NMLVL OF THIS BLOCK
05600 CAMLE TBITS2,TEMP ;IF NEW LEVEL LOWER, DON'T INCLUDE IT,
05700 JRST DOSYML ; RETURN TO FORWARD SEARCH
05800 HLRZ TEMP,B ;GET CURRENT "QSTACK" POINTER
05900 SETZM 1(TEMP) ;ZERO "POPPED" ENTRY
06000 SOS BLKCNT ;SUBTRACT ONE FOR EACH ONE ALLOCATED
06100 PUSH P,%TLINK(LPSA) ;
06200 PUSH P,B
06300 PUSHJ P,NOSY ;ALLOCATE SYMBOLS FOR THIS BLOCK
06400 POP P,B
06500 POP P,LPSA ;SEE IF HAD A SECOND SEMBLK
06600 TLNN LPSA,-1 ;IF NOT
06700 JRST DOSYL1 ;CONTINUE BACKWARDS SEARCH
06800 HLRZ LPSA,LPSA ;WE DID
06900 FREBLK ;DONE WITH IT NOW
07000 JRST DOSYL1 ;CONTINUE BACKWARDS
07100
07200 ;STEP 6 -- PUT OUT PROCNAME BLOCK IF NOT ALL GONE
07300 DIDSYM: SKIPG BLKCNT ;DID WE SEE SOME WE DIDN'T ALLOCATE?
07400 JRST DIDALL ; NO, ALL DONE
07500 SETOM BLKCNT ;WON'T FAIL AGAIN
07600 MOVE LPSA,TPROC ;USE PROCEDURE NAME AS OUTER BLOCK NAME
07700 PUSHJ P,BLBOUT
07800 MOVNI TBITS2,1 ;VERRRY LOW LEVEL
07900 MOVE B,BLKIDX ;LOOK AT ALL POSSIBLE ENTRIES
08000 JRST DOSYL1 ;GO ROUND ONCE MORE, GET THE REST
08100
08200 ;STEP 7 -- CLEAN UP
08300 DIDALL: QFLUSH (BLKIDX) ;RELEASE STORAGE, CLEAR QPDP
08400 SKIPE SIMPSW ;NO PD FOR SIMPLE
08500 JRST CRECHK ;
08600 CRECHK:
08700 NOGAG <
08800 TLNN FF,CREFSW ;IF ¬CREFFING, DONE.
08900 POPJ P, ;DONE
09000 MOVE LPSA,TPROC ;PROCEDURE NAME
09100 CAIE LPSA,RESYM ;NOT THIS ONE;
09200 JRST CREFBLOCK ;FOR BLOCK EXIT.
09300 >;NOGAG
09400 APOPJ: POPJ P,
09500
00100 NOSY: PUSHJ P,URGSTR ;IF ON STRING RING....
00200 FREBLK ;DELETE THE BLOCK.
00300 RIGHT ,%RVARB,APOPJ ;GO TO NEXT BLOCK.(OR POPJ)
00400 SY2A: MOVE TBITS,$TBITS(LPSA)
00500 TLNE FF,CREFSW ;IF CREFFING.
00600 PUSHJ P,CREFDEF ;DEFINE THE SYMBOL.
00700 TLNE TBITS,RES ;IF RESERVED WORD (NEW DEF),
00800 JRST NOSY ; (VIA LET) , FORGET IT
00900 TLNE TBITS,SBSCRP ;TURN OFF STRING IF ARRAY
01000 TRZ TBITS,STRING
01100 PUSHJ P,RAD50 ;MAKE SURE A SYMBOL NAME GETS MADE
01200 TRNE TBITS,ITEM
01300 TLNE TBITS,FORMAL!SBSCRP!EXTRNL ;PUT OUT ITEM NUMBER IF
01400 JRST NOITMS ;IT IS THERE.
01500 HRRZ TEMP,$VAL2(LPSA) ;POINTER TO INTEGER.
01600 MOVE B,$VAL(TEMP) ;ITEM NUMBER.
01700 PUSHJ P,SCOUT0 ;NO RELOCATION.
01800 JRST NOSY
01900 NOITMS: HRRZ B,$ADR(LPSA) ;FIXUP
02000 ;;#KY# ALLOW GLOBAL INTERNAL SYMBOLS OUT (FIX 1 OF 2)
02100 TRNE TBITS,GLOBL ;
02200 TLNN TBITS,INTRNL ;
02300 ;;#KY# 1 OF 2
02400 JUMPE B,NOSY1 ;NO SYMBOL
02500 GLOC <
02600 TRNE TBITS,GLOBL ;IF NOT GLOBAL
02700 TRNE TBITS,ITEM ;OR IT ITEM, THEN
02800 JRST REGSYM ;NOT POSSIBLY A GLOBAL TYPE.
02900 HRLZ B,$ADR(LPSA) ;FIXUP CHAIN
03000 HLR B,$VAL2(LPSA) ; AND THE GLOBAL NUMBER.
03100 ADDI B,400013 ; GLOBAL DATA BASE.
03200 HRRM B,$ADR(LPSA) ;FOR THE SYMBOL....
03300 ;;#KY# ↓ 2 OF 2
03400 TLNE B,-1 ;ANY TO FIX UP?
03500 PUSHJ P,FIXOUT ;FIXUP WITH NO RELOCATION.
03600 PUSHJ P,SCOUT0 ;PUT OUT SYMBOL WITH NO RELOC.
03700 JRST NOSY
03800 REGSYM:
03900 >;GLOC
04000 ;;#II#↓ 7-4-72 DCS DON'T LET DEFINES OUT!
04100 TLNN TBITS,DEFINE
04200 PUSHJ P,SOUT ;OUTPUT THE SYMBOL.
04300 TRC TBITS,FORWRD!LABEL
04400 TRCN TBITS,FORWRD!LABEL ;HAS A LABEL BEEN USED BUT NOT DEFINED?
04500 ERR <UNUSED LABEL: >,3
04600 NOSY1: TRNE TBITS,PROCED
04700 JRST PPR ;PROCEDURE AND FRIENDS.
04800 TLNN TBITS,DEFINE ;DELETE THE MACRO BODY ....
04900 JRST CHARYZ ;CHECK ARRAYS.
05000 PUSH P,LPSA
05100 LEFT ,%TLINK,LPSERR
05200 PUSHJ P,URGSTR ;UNLINK MACRO BODY.
05300 POP P,LPSA
05400 JRST NOSY ;ALL DONE
05500
05600 CHARYZ: TLNN TBITS,SBSCRP ;ARRAY?
05700 JRST CHKTWO ; NO
05800
05900 PUSH P,LPSA
06000 HRRZ B,$VAL(LPSA) ;ARRAY ADDRESS IF OWN ARRAY
06100 MOVE A,RAD5. ;DOTTED SYMBOL NAME
06200 TLZ A,740000 ;MAKE AN INTERNAL SYMBOL!
06300 TLO A,100000 ;LIKE THIS
06400 TLNE TBITS,OWN ;BUILT IN?
06500 PUSHJ P,SCOUT ; YES, PUT OUT A SYMBOL
06600 LEFT ,%TLINK,NOBBLK ;DELETE BNDBLK (SEE ARRAY)
06700 FREBLK
06800 NOBBLK: POP P,LPSA ; IF THERE IS ONE
06900
07000 CHKTWO: TLNE TBITS,INTRNL!EXTRNL ;IS THERE
07100 TRNN TBITS,STRING ;A SECOND SYMBOL?
07200 JRST NOSY ;NO -- DONE
07300 MOVE A,RAD5. ;GET KLUDGED UP VERSION OF SYMBOL
07400 HLRZ B,$ADR(LPSA) ;GET ADDRESS FOR 2D WORD
07500 JUMPE B,NOSY ;AN EXTERNAL STRING COULD CAUSE THIS
07600 PUSHJ P,SCOUT ;OUTPUT SYMBOL
07700 JRST NOSY
07800
07900 PPR: TLNE TBITS,EXTRNL!MESSAGE ;DON'T MAKE THIS CHECK FOR EXTERNALS
08000 JRST PPR1
08100 TRNE TBITS,FORWRD ;CHECK FOR FORWARD NEVER DEFINED
08200 ERR <FORWARD PROCEDURE NEVER DEFINED: >,3
08300 PPR1: PUSH P,LPSA
08400 LEFT ,%TLINK,LPSERR ;LPSA → 2D PROC BLOCK
08500 MOVE A,LPSA ;SAVE POINTER
08600 LEFT (,%TLINK) ;→FIRST PARAM OR NIL
08700 PUSHJ P,KILLST ;DELETE ALL FORMALS
08800 FREBLK (A) ;DELETE 2D PROC BLOCK
08900 ;THE FOLLOWING CODE HANDLES THE PROCEDURE DESCRIPTOR
09000 MOVE LPSA,(P) ;PICK UP PROCEDURE
09100 HRRZ A,$VAL(LPSA) ;PICK UP THE PD SEMBLK
09200 JUMPE A,NOPD
09300 TLNN TBITS,EXTRNL ;EXTERNAL?
09400 JRST NOEXPD ;NO
09500 SKIPGE C,$ADR(A) ;OUT ALREADY??
09600 ERR <DRYROT AT NOSY --EXTERNAL PD >,1
09700 TRNN C,-1 ;FIXUPS??
09800 JRST PDFDON ;NO
09900 PUSH P,B
10000 PUSH P,A
10100 HRLM C,PDFFHD ;REMEMBER FIXUP HEAD
10200 PUSHJ P,RAD50 ;GET PROCEDURE RADIX50
10300 TLC A,640000 ;CHANGE TYPE BITS
10400 HLRM A,R5PD1 ;SAVE RADIX50 IN BLOCK
10500 ;;#KM# RHT ↓ 11-24-72 "B"→→ "A"
10600 HRLM A,R5PD2
10700 MOVE B,PDPFBD ;POLISH FIXUP BLOCK DESC
10800 PUSHJ P,FRBT ;FLUSH BN OUTPUT
10900 PUSHJ P,GBOUT ;PUT OUT THE BLOCK
11000 POP P,A
11100 POP P,B
11200 JRST PDFDON
11300 NOEXPD:
11400 ;;#IV# RHT (9-22-72) IGNORE FORWARD PROCEDURES HERE
11500 TRNE TBITS,FORWRD
11600 JRST PDFDON
11700 ;;#IV#
11800 PUSH P,A
11900 PUSHJ P,RAD50 ;GET RADIX 50 SYMBOL
12000 MOVE A,RAD5$ ;THE $ SYMBOL
12100 TLZ A,740000
12200 TLO A,100000 ;LOCAL PROCEDURE
12300 HRRZ B,$VAL(LPSA)
12400 SKIPL B,$ADR(B) ;THE ADDRESS
12500 ERR <DRYROT AT NOSY -- NON EXTERNAL PROC>
12600 PUSHJ P,SCOUT ;PUT PD SYMBOL OUT
12700 POP P,A ;
12800 PDFDON: HLRZ C,%TLINK(A) ;POINT AT PDA,,0 SEMBLK
12900 FREBLK (A) ;FREE PD BLOCK
13000 JUMPE C,NOPD ;FREE PDA,,0 BLOCK IF HAVE ONE
13100 FREBLK (C)
13200 NOPD:
13300 POP P,LPSA
13400 GLOC <
13500 ;;#JF# RHT (9-27-72) ↓ BE SURE MESSAGE BLOCK GETS RIGHT ADDR
13600 HRRZ B,$ADR(LPSA) ;
13700 CAIE B,0 ;IF FORWARD MESSAGE DESCRIP. NEVER DEFINED
13800 TLNN TBITS,MESSAGE ;AND IS DEFINITELY A MESSAGE
13900 JRST NOSY ; --
14000 TLO FF,RELOC ;FIRST GOES THE WORD WHICH CHAINS LINKS.
14100 HRRO A,PCNT
14200 NOGAG <
14300 EXCH A,MESLNK ;MESSAGE LINK
14400 >;NOGAG
14500 GAG <
14600 EXCH A,MESLNK-SPCDAT+WOMSPC
14700 >;GAG
14800 PUSHJ P,CODOUT ;PUT IT OUT
14900 HRL A,$PNAME(LPSA) ;STRING COUNT
15000 HRR A,B ;ADDRESS OF PROCEDURE
15100 TLO FF,RELOC ;AGAIN SINCE IF MESLNK WAS ZERO, OUR FRIEND
15200 ;CODOUT RESET RELOC.......
15300 PUSHJ P,CODOUT ;XWD #CHARS,,PROD ADDRESS.
15400 TLZ FF,RELOC
15500 HRRZ C,$PNAME(LPSA) ;#CHARS AGAIN.
15600 ADDI C,4 ;..
15700 IDIVI C,=5
15800 MES21: AOS B,$PNAME+1(LPSA);WE CAN HAPPILY DESTROY THE BYTE POINTER.
15900 MOVE A,-1(B) ;FIRST WORD OF PNAMES.
16000 PUSHJ P,CODOUT ;OUT IT GOES.
16100 MOVE A,(B) ;NEXT WORD
16200 CAIGE C,2 ;...
16300 MOVEI A,0 ;NOT TWO WORDS LONG.
16400 PUSHJ P,CODOUT
16500 >;GLOC
16600 JRST NOSY ;AND LOOP.
16700
16800
00100 ;LOADER BLOCK FOR POLISH FIXUP
00200 LODBLK(,11,PDPFB,PDPFBD,5,,<XWD 001000,0>)
00300 RELOC .-5
00400 XWD 3,1 ;ADD , LITC
00500 -1
00600 R5PD1: XWD 2,0 ;OPDC ,, LH OF RAD50
00700 R5PD2: XWD 0,-1 ;RH OF RAD50,,SHR
00800 PDFFHD: XWD 0,0 ;DEST ,,0
00900 DSCR BLBOUT
01000 CAL PUSHJ
01100 PAR LPSA is Semantics of Block with a name
01200 DES outputs a Block name LOADER block via GBOUT. Saves RADIX50 for
01300 name, and SHOUT makes sure that no two consecutive blocks output
01400 with the same names. This can happen: PRODEDURE FINIS (..);
01500 BEGIN "FINIS" ... two identical block names
01600 cause havoc with DDT.
01700 SID Uses most ACs except SBITS, PNT2 group
01800 ⊗
01900
02000 BLBOUT:
02100 MOVE TBITS,$TBITS(LPSA) ;SEE IF IT IS A PROCEDURE OR NOT
02200 HRRZ B,$VAL2(LPSA) ;LEVEL (DDT) OF THIS BLOCK
02300 TRNN TBITS,PROCED ;IF PROCEDURE,
02400 ; GET LEVEL FROM DIFFERENT PLACE
02500 JRST NOPRCC
02600 HLRZ TEMP,%TLINK(LPSA)
02700 HRRZ B,$VAL2(TEMP)
02800 NOPRCC: PUSHJ P,RAD50 ;GET BLOCK NAME IN RADIX50
02900 TLZ A,740000 ;CLEAR SYMBOL TYPE BITS
03000 TLO A,140000 ;PUT IN THE RIGHT ONES
03100 PUSHJ P,SCOUT ;PUT OUT BLOCK NAME
03200 MOVEM A,LSTRAD ;SAVE RADIX50 FOR THE BLOCK NAME.
03300 TRNE TBITS,PROCED
03400 POPJ P,
03500 MOVE A,RAD5.
03600 TLZ A,740000 ;SHOULD BE BLOCK TYPE 10
03700 TLO A,100000
03800 HLRZ B,$VAL2(LPSA)
03900 PPFF: JRST SCOUT ;MAKE LABEL FOR BLK OR CMPD STMT.
04000
04100
00100 DSCR PDOUT
00200 DES ROUTINE TO OUTPUT THE PROCEDURE DESCRIPTOR -- USED ONLY FOR DISPLAY SYSTEMS
00300 PARM PROC SEMBLK ADDRESS IN PNT2
00400 SID ALL ACCUMULATORS SAVED EXCEPT TEMP & LPSA
00500 ⊗
00600 DIS <
00700
00800 BITDATA( PROC DESC STUFF)
00900 BLKCOD←←17 ;BLOCK BOUNDARY CODE
01000 EOPCOD←←0 ;END OF PROC LVI CODE
01100 AACOD←←1 ;ARITH ARRAY
01200 SACOD←←2 ;STRING ARRAY
01300 SETCOD←←3 ;SET
01400 LACOD←←4 ;LIST OR SET ARRAY
01500 FRCCOD←←5 ;FOREACH STATEMENT
01600 KLCOD←←6 ;KILL LIST
01700 CTXCOD ←← 7 ;CONTEXT
01800 CLNCOD ←← 10 ;CLEANUP PROC
01900 ENDDATA
02000
02100 PDOUT: PUSH P,FF ;SAVE FF
02200 PUSH P,A
02300 PUSH P,B
02400 PUSH P,C
02500 PUSH P,SBITS2
02600 PUSH P,TBITS
02700 PUSH P,PNT
02800 HRRZ PNT,$VAL(PNT2) ;PICK UP PD SEMBLK
02900 JUMPE PNT,XPDOUT ;IF OUTER BLOCK, NOTHING GOES OUT
03000 MOVEI A,0
03100 TLZ FF,RELOC
03200 PUSHJ P,CODOUT
03300 COMMENT ⊗ ****** ON THE MAGIC DAY *****
03400 MOVEI B,PDLINK ;LINK THE PROC DESC
03500 PUSHJ P,LNKOUT
03600 ⊗;**************************************
03700 HRRZ B,PCNT ;THE CURRENT ADDRESS
03800 HRL B,$ADR(PNT) ;FIXUP REFERENCES TO PDA
03900 HRROM B,$ADR(PNT) ;REMEMBER THE FACT THAT PDA IS RIGHT
04000 TLNE B,-1 ;IF THERE WERE ANY
04100 PUSHJ P,FBOUT ;DO IT
04200 HRRZ A,$ADR(PNT2) ;ADDRESS OF PROC ENTRY
04300 TLO FF,RELOC
04400 PUSHJ P,CODOUT
04500 HRRZ A,$PNAME(PNT2) ;LENGTH OF THE NAME
04600 TLZ FF,RELOC
04700 PUSHJ P,CODOUT ;PUT IT OUT
04800 HRRZ B,PCNT
04900 HRRM B,$PNAME+1(PNT) ;REMEMBER THIS SPOT
05000 MOVE A,[POINT 7,0] ;BYTE PTR WORD FOR PNAME
05100 PUSHJ P,CODOUT
05200 MOVE A,$TBITS(PNT2)
05300 PUSHJ P,CODOUT ;PUT OUT PROCEDURE TBITS
05400 HLRZ B,%TLINK(PNT2) ;POINT AT 2ND PROC SEMBLK
05500 MOVS A,$NPRMS(B) ;#SPARMS*2,,#APRMS +1 →→ A
05600 PUSHJ P,CODOUT ;PUT IT OUT
05700 HRL A,SSDIS ;+SS DISP
05800 HRR A,ASDIS ;+AS DISP
05900 PUSHJ P,CODOUT ;
06000 LLPUT: HRLZ A,$SBITS(PNT2)
06100 AND A,[XWD LLFLDM,0] ;LEX LEV
06200 HRR A,$VAL2(PNT) ;LVI FIXUP
06300 HRL B,PCNT
06400 HLRM B,$VAL2(PNT)
06500 TLO FF,RELOC
06600 PUSHJ P,CODOUT
06700 DLPUT: HRLZ A,CDLEV ;CURRENT DISPLAY LEVEL
06800 HRR A,$VAL(PNT) ;PARAM INFO FIXUP
06900 HRL B,PCNT ;
07000 HLRM B,$VAL(PNT)
07100 TLO FF,RELOC
07200 PUSHJ P,CODOUT
07300 HLRZ B,%TLINK(PNT) ;POINT AT [PDA,,0] SEMBLK
07400 CAIN B,0 ;DO WE HAVE ONE
07500 JRST PDAX0 ;NO
07600 HRL B,$ADR(B)
07700 HRR B,PCNT ;HERE IT IS
07800 TLNE B,-1
07900 PUSHJ P,FBOUT
08000 PDAX0: HRLZ A,$ADR(PNT) ;PICK UP PDA INTO LH
08100 PUSHJ P,CODLRL ;GO RELOCATE LH
08200 HLRZ C,%TLINK(PNT2) ;LOOK AT 2ND PROC SEMBLK
08300 HRRZ C,%SAVET(C) ;TO FIND PARENT PROC
08400 MOVEI A,0 ;
08500 JUMPE C,[ TLZ FF,RELOC ;IF THE TOP LEVEL (I.E. NO DADDY)
08600 PUSHJ P,CODOUT ;PUT OUT THE 0
08700 JRST PCPRD] ;GO ON TO NEXT THING
08800 HRRZ C,$VAL(C) ;PD SEMBLK
08900 HRRZ A,$ADR(C) ;EASIEST TO CHAIN BY SELF
09000 HRR B,PCNT ;NEW CHAIN
09100 HRRM B,$ADR(C)
09200 HLL A,$ACNO(PNT) ;PCNT AT END OF MKSEMT
09300 PPDA0: TLO FF,RELOC
09400 PUSHJ P,CODLRL ;GO PUT IT OUT
09500 PCPRD: MOVE A,$ACNO(PNT2) ;PCNT AT PRDEC,,EXIT(FIXED UP)
09600 HRR A,$ACNO(PNT) ;PICK UP EXIT FROM PD SEMBLK
09700 TLO FF,RELOC
09800 PUSHJ P,CODLRL ;RELOC BOTH HALVES
09900 HLRZ C,%TLINK(PNT2) ;SECOND PROC SEMBLK
10000 HLRZ C,%SAVET(C) ;OLD TTOP
10100 HRLZ A,PCNT ;
10200 HLR A,$SBITS(C) ;FIXUP LVI REF TO PARENT BLOCK
10300 HLLM A,$SBITS(C) ;FIXUP CONTINUED
10400 HRRZS A ;SCRATCH THE OLD CRUFT
10500 PUSHJ P,CODOUT ;PUT IT OUT
10600 TLZ FF,RELOC
10700 HLRZ LPSA,%TLINK(PNT2) ;LPSA← →→ 2ND PROC SEMBLK
10800 HLRZ LPSA,%TLINK(LPSA) ;LPSA NOW →→ FIRST PARA
10900 JUMPE LPSA,DOLVIN ;THERE MAY NOT BE ANY
11000 HRR B,PCNT
11100 HRL B,$VAL(PNT) ;LOC OF START OF PROC PARAM INFO
11200 PUSHJ P,FBOUT
11300
11400 NPTB: MOVE A,$TBITS(LPSA) ;PICK IT UP
11500 PUSHJ P,CODOUT ;PUT IT OUT
11600 RIGHT ,%RVARB,DOLVIN
11700 JRST NPTB ;GO DO NEXT ONE
11800
00100 DOLVIN: PUSH P,PNT2
00200 HRR B,PCNT
00300 HRL B,$VAL2(PNT)
00400 PUSHJ P,FBOUT
00500 MOVE PNT,$SBITS(PNT2)
00600 ANDI PNT,LLFLDM ;LEX LEVEL
00700 SKIPE SBITS2,BLKIDX ;PICK UP
00800 PUSHJ P,LVIOUT
00900 POP P,PNT2
01000 TLZ FF,RELOC
01100 MOVEI A,0
01200 PUSHJ P,CODOUT ;PUT OUT END OF LVI FLAG
01300 MOVE PNT,$VAL(PNT2) ;PD SEMBLK AGAIN
01400 HRL B,$PNAME+1(PNT) ;FIX UP THE STRING REFERENCE
01500 HRR B,PCNT
01600 PUSHJ P,FBOUT
01700 HRRZ SBITS2,$PNAME(PNT2) ;LEN OF PNAME
01800 TLZ FF,RELOC ;DO NOT RELOCATE
01900 MOVE LPSA,$PNAME+1(PNT2) ;BYTE PTR FOR PNAME
02000 TRDY: MOVE TEMP,[POINT 7,A]
02100 MOVEI A,0
02200 MOVEI B,5
02300 TPNC: SOJL SBITS2,PNMDN
02400 ILDB C,LPSA ;PICK UP CHAR
02500 IDPB C,TEMP ;PUT IT DOWN
02600 SOJG B,TPNC
02700 PUSHJ P,CODOUT
02800 JRST TRDY
02900 PNMDN: CAIE B,5
03000 PUSHJ P,CODOUT
03100 XPDOUT: POP P,PNT ;RETURN
03200 POP P,TBITS
03300 POP P,SBITS2
03400 POP P,C
03500 POP P,B
03600 POP P,A
03700 POP P,FF
03800 POPJ P,
03900
04000
00100 ;ROUTINE TO PUT OUT LOCAL VAR INFO -- USED BY DIS
00200 ;PARAMS -- BLOCK QPDP IN SBITS2,, LEX LEV IN PNT
00300
00400
00500 LVIOUT: PUSH P,[-1] ;CLEVER FLAG TO CATCH BIG PARENT
00600 LVIO.1: MOVE B,SBITS2
00700 QBACK
00800 JRST LVIEXT ;ALL DONE
00900 MOVEM B,SBITS2
01000 MOVE PNT2,A ;GET HIS NAME
01100 LDB PNT,[POINT LLFLDL,$SBITS(PNT2),=35]
01200
01300 HRRZ B,PCNT
01400 HLL B,$SBITS(PNT2)
01500 TLNE B,-1
01600 PUSHJ P,FBOUT ;FIXUP REFS FOR THIS BLOCK'S INFO, IF ANY
01700 HRLM B,$SBITS(PNT2) ;REMEMBER MY SPOT
01800 HLRZ LPSA,%TLINK(PNT2) ;SECOND PROC SEMBLK
01900 JUMPE LPSA,LIT.1 ;NONE
02000 SKIPN $ACNO(LPSA) ;THE QPDP FOR CLEANUPS
02100 JRST LIT.1 ;NONE
02200 QBEGIN (<$ACNO(LPSA)>) ;GET INITIAL QPDP
02300 LIT.0: QTAKE ;TAKE ONE
02400 JRST LIT.X ;DONE
02500 MOVE TBITS,$TBITS(A) ;GET TYPE
02600 MOVE C,A ;
02700 HRRZ A,$ADR(C) ;ADDRESS
02800 TDNN TBITS,[XWD EXTRNL,FORWRD+INPROG] ;NEED FIXUP?
02900 JRST LIT.01 ;NO
03000 HRL C,PCNT ;YES
03100 HLRM C,$ADR(C) ;
03200 LIT.01: HRLI A,CLNCOD⊗=14 ;TYPE IS CLEANUP
03300 DPB PNT,[ POINT =9,A,=12] ;LEX LEV
03400 TLO FF,RELOC ;RELOC
03500 PUSHJ P,CODOUT ;
03600 JRST LIT.0 ;GET NEXT
03700 LIT.X: QFLUSH
03800 LIT.1: MOVE LPSA,PNT2
03900 LITER: RIGHT ,%RVARB,EBK ;GO DOWN VARB RING
04000 MOVE TBITS,$TBITS(LPSA) ;PICK UP TYPE BITS
04100
04200 ;;#IT# RHT 8-4-72 ↓ KEEP OUT EXTERNALS
04300 ;;#IZ# RHT 9-25-72 ↓ ALSO KEEP OUT GLOBALS
04400 TDNE TBITS,[XWD EXTRNL!OWN,GLOBL!PROCED];OWN STUFF NEVER GOES,
04500 ; ALSO NO PROCS OR EXTERNALS
04600 JRST LITER
04700 TLNE TBITS,SBSCRP
04800 JRST ARYINF
04900 ;;# # DCS 5-3-72 SETS, BUT NOT SET ITEMS!!
05000 TRNE TBITS,ITMVAR!ITEM ;CHECK IT OUT -- DCS
05100 JRST LITER ;LOOP
05200 ;;# # 5-3
05300 TRNE TBITS,SET ;SET??
05400 JRST SETINF
05500 TRNE TBITS,INTEGR ;TEST FOR THE FOREACH KLUGE (FLOATING INTEGER)
05600 TRNN TBITS,FLOTNG
05700 JRST LITER ;LOOP
05800 FRCINF: MOVEI B,FRCCOD ;FOREACH CODE
05900 JRST PUTCI
06000
06100 ARYINF: TLNE TBITS,BILTIN ;BUILT IN
06200 JRST LITER ;YES,DONT BOTHER
06300 MOVEI B,AACOD ;ARITH CODE
06400 TRNE TBITS,STRING ;MAYBE IT WAS A STRING ARRAY
06500 MOVEI B,SACOD
06600 TRNE TBITS,SET ;OR A LEAPISH THING
06700 MOVEI B,LACOD
06800 JRST PUTCI
06900 ;;# # RHT 8-1-72 KILL SET
07000 SETINF: TLNN TBITS,SAFE ;CHECK IF KILL SET
07100 JRST SETI.1 ;NO
07200 TRNN TBITS,INTEGR ;BE SURE
07300 ERR <DRYROT AT LVIOUT>
07400 MOVEI B,KLCOD
07500 JRST PUTCI
07600 ;;# # RHT 8-1-72
07700 SETI.1: SKIPN RECSW
07800 JRST LITER
07900 MOVEI B,CTXCOD ;CONTEXT?
08000 TLNE TBITS,FLOTNG ;CHECK
08100 JRST PUTCI
08200 MOVEI B,SETCOD
08300 PUTCI: MOVEI A,0
08400 SKIPE RECSW ;IS THIS FORB RECURSIVE??
08500 HRLZI A,RF
08600 DPB B,[POINT 4,A,3]
08700 DPB PNT,[POINT =9,A,=12]
08800 TLO FF,RELOC
08900 SKIPE RECSW
09000 TLZ FF,RELOC
09100 HRR A,$ADR(LPSA)
09200 TRNE A,-1 ;DID IT GET USED?? - IF SO MUST BE NON ZERO FOR
09300 ;EITHER CORE OR STACK (SINCE (F) IS DYN LINK)
09400 PUSHJ P,CODOUT
09500 JRST LITER
09600
09700 EBK: HRLZ A,PNT
09800 LSH A,5 ;PUT LEX LEV IN RIGHT SPOT
09900 MOVEI B,BLKCOD ;SAY IT IS A BLOCK
10000 DPB B,[POINT 4,A,3]
10100 AOSN (P) ;IS THIS THE OUTER BLK FOR THIS PD
10200 JRST .+4 ;YES LINK UP IS ZERO
10300 HLRZ B,$ADR(PNT2) ;
10400 HLR A,$SBITS(B) ;RH OF A ←← PARENT'S LVI AREA
10500 TLOA FF,RELOC ;
10600 TLZ FF,RELOC ;NEVER RELOC 0
10700 PUSHJ P,CODOUT ;PUT OUT FLAG WORD
10800 JRST LVIO.1 ;GO GET NEXT BLOCK
10900 LVIEXT: SUB P,[XWD 2,2] ;FLUSH THE FLAG
11000 JRST @1(P) ;RETURN
11100
11200
11300 >;DIS
11400
11500
00100 COMMENT ⊗Allo -- Allocate One Type of Symbol
00200 ALLO looks at each symbol and outputs its core locations, etc.
00300 It also outputs fixups, and saves the final core address in
00400 $ADR so that the symbol-outputter can find it.
00500 ⊗
00600 ALLO: MOVEI PNT2,0 ;COUNT OF LOCALS ALLOCATED.
00700 SKIPN SBITS2,BLKIDX ;GET QPDP FOR BLOCK QSTACK
00800 JRST CPOPJ ; NOTHING TO ALLOCATE
00900
01000 ITE: MOVE B,SBITS2 ;GET QPDP TO PARAM POSITION
01100 QBACK ;NON-DESTRUCTIVE QPOP
01200 JRST [HRR A,FIRSYM ;SET UP ALIMS-TYPE WORD
01300 HRL A,LSTSYM
01400 POPJ P,] ;DONE
01500 MOVEM B,SBITS2 ;SAVE UPDATED QPDP
01600 MOVE LPSA,A
01700 ITER: RIGHT ,%RVARB,ITE ;GO DOWN LIST
01800 MOVE TBITS,$TBITS(LPSA) ;TYPE BITS.
01900 TRNE TBITS,SET ;IF A SET DO NOT ALLOCATE AS ARITH TOO
02000 TRZ TBITS,FLOTNG!INTEGR
02100 TLNE TBITS,SBSCRP ;DO NOT ALLOCATE AS BOTH ARRAY AND INTEGER!!!
02200 TRZ TBITS,STRING!INTEGR!FLOTNG!ITMVAR!ITEM!SET!LSTBIT!LPARRAY!SHORT
02300 TRNE TBITS,ITEM!ITMVAR
02400 TRZ TBITS,STRING!INTEGR!FLOTNG!SET!LSTBIT
02500 TRNN TBITS,PROCED!LABEL ;NEVER SPACE FOR THESE.
02600 TDNN TBITS,TBITS2 ;USE THE MASK.
02700 JRST ITER ;NO MATCH -- GO FARTHER
02800
02900 ALOWDS:
03000 TDNE TBITS,[XWD EXTRNL!DEFINE,GLOBL] ;PUT OUT NO CODE
03100 ; OR FIXUPS FOR EXTERNALS
03200 JRST ITER
03300 TLNE TBITS,SBSCRP ;ALWAYS ALLOCATE ARRAYS
03400 JRST ANYWAY
03500 SKIPN B,$ADR(LPSA) ;IF $ADR IS 0 AND SYMBOL IS NOT
03600 TLNN TBITS,INTRNL ; INTERNAL, DON'T PUT OUT CODE OR FIXUPS
03700 JUMPE B,ITER
03800 ANYWAY:
03900 DIS <
04000 SKIPE RECSW ;IF NOT RECURSIVE
04100 TDNE TBITS,[XWD OWN,ITEM] ;OR VAR IS OWN, ITEM OR THE LIKE
04200 JRST ALCV ;IT GETS INTO CORE
04300 AOS B,CSPOS ;USE A STACK LOCN
04400 TLNN FF,ALLOCT ;ALLOCATING?
04500 JRST [TRNE TBITS,STRING ;NO-- IS IT A STRING?
04600 AOS CSPOS ;YES
04700 JRST ITER]
04800 HRL B,$ADR(LPSA) ;FIRST FIXUP
04900 HRRM B,$ADR(LPSA) ;SAVE ITS SACK INC
05000 TLNE B,-1 ;MIGHT BE UNUSED
05100 PUSHJ P,FIXOUT ;NO RELOC FOR FIXED UP VALUE
05200 TRNN TBITS,STRING ;STRING????
05300 JRST ITER ;NO -- DONE WITH THIS
05400 AOS B,CSPOS ;BUMP STACK DISPL
05500 HLL B,$ADR(LPSA) ;SECOND WORD FIXUP CHAIN
05600 HRLM B,$ADR(LPSA) ;SAVE IT
05700 TLNE B,-1 ;USED?
05800 PUSHJ P,FIXOUT ;YES
05900 JRST ITER ;AT LAST
06000 ALCV:
06100 >;DIS
06200 MOVEM LPSA,LSTSYM ;LAST SYMBOL
06300 AOS PNT2 ;INCREMENT COUNT.
06400 SKIPN FIRSYM
06500 MOVEM LPSA,FIRSYM ;RECORD FIRST SYMBOL ONCE!!
06600 TLNN FF,ALLOCT ;ACTUALLY ALLOCATE?
06700 JRST ITER ;NO -- LOOP
06800 NOGAG < ;DON'T NEED FIXUPS IN "GOGOL"
06900 HRLZ B,$ADR(LPSA) ;FIRST FIXUP
07000 HRR B,PCNT
07100 HRRM B,$ADR(LPSA) ;SAVE THE PCNT FOR SOUT TO FIND.
07200 TLNE B,-1 ;IN CASE A STRING WHICH ONLY USES SECOND WD.
07300 PUSHJ P,FBOUT ;OUTPUT THE FIXUP
07400 >;NOGAG
07500
07600 ; BUG TRAP -- $VAL SHOULD GENERALLY BE 0 THRU HERE
07700
07800 SKIPE A,$VAL(LPSA) ;VALUE WORD
07900 TRNE TBITS,ITEM ;EXCEPT ITEMS.........
08000 JRST NVL ; IT IS ZERO
08100 TLNN TBITS,SBSCRP ;CAN BE NON-ZERO IF ARRAY
08200 ERR <DRYROT -- ALLO>,1
08300 NVL:
08400 NOGAG <
08500 TLZ FF,RELOC
08600 TLNE TBITS,SBSCRP ;WANT RELOCATABLE IF ARRAY
08700 TLO FF,RELOC ; UNLESS IT IS ZERO
08800
08900 PUSHJ P,CODOUT ;OUTPUT A WORD FOR IT!
09000 TLZ FF,RELOC ;MAKE SURE IT'S OFF
09100 TRNN TBITS,STRING ;DO WE WANT STILL ANOTHER WORD?
09200 JRST ITER ;NO -- LOOP
09300 HLLZ B,$ADR(LPSA) ;SECOND FIXUP
09400 HRR B,PCNT
09500 HRLM B,$ADR(LPSA) ;SAVE THIS FOR 2D SYMBOL IF ANY
09600 TLNE B,-1 ;IN CASE NOT USED.
09700 PUSHJ P,FBOUT ;OUTPUT FIXUP
09800 MOVEI A,0
09900 PUSHJ P,CODOUT ;AND A WORD OF STORAGE.
10000 >;NOGAG
10100 JRST ITER ;LOOP
10200
10300
10400
00100 ;ROUTINE TO ALLOCATE SPACE FOR TEMP CELLS AND TO OUTPUT
00200 ;FIXUPS.
00300
00400 TMPALO: SETZM PNT2 ;COUNT
00500 HRRZ LPSA,TTEMP
00600 JUMPE LPSA,CPOPJ
00700 TMPAL: MOVE SBITS,$SBITS(LPSA) ;S BITS.
00800 TLNN SBITS,CORTMP ;A CORE TEMP?
00900 JRST TMNXT ;NO
01000 MOVEM LPSA,LSTSYM ;SAVE
01100 SKIPN FIRSYM ;NO ARITH VARIABLES?
01200 MOVEM LPSA,FIRSYM ; THAT'S RIGHT, THIS TEMP IS FIRST
01300 MOVEI TEMP,INTEGR ;MIGHT BE INDXED STRING TEMP LEFT OVER,
01400 MOVEM TEMP,$TBITS(LPSA) ;THIS IS EASIEST WAY TO AVOID CONFUSION
01500 ;(PRUP CHECKS STRING, DOES FXTWO, WE DON'T
01600 ; WANT THAT HERE)
01700 TLZ SBITS,INDXED!FIXARR ;DO SOME THINGS TO SBITS TOO
01800 TLZE SBITS,INAC!PTRAC!STTEMP ;ONLY REMAINING USE IS
01900 ERR <DRYROT -- TMPALL>,1 ; FOR REC. PROC BLT CODE
02000 MOVEM SBITS,$SBITS(LPSA) ;(MORE HONESTY)
02100 AOS PNT2
02200 SKIPN RECSW ;IF NOT RECURSIVE
02300 JRST ALCTMP ;THEY GO TO CORE
02400 AOS B,CSPOS ;BUMP THE STACK OFFSET
02500 TLNN FF,ALLOCT ;ACTUALLY ALLOCATE?
02600 JRST TMNXT ;NO
02700 HRL B,$ADR(LPSA) ;PICK UP FIXUP CHAIN
02800 PUSHJ P,FIXOUT ;FIXUP
02900 JRST TMNXT
03000 ALCTMP:
03100 TLNN FF,ALLOCT ;ACTUALLY ALLOCATE?
03200 JRST TMNXT ;NO
03300
03400 NOGAG <
03500 HRR B,PCNT
03600 HRL B,$ADR(LPSA)
03700 PUSHJ P,FBOUT ;FIXUP
03800 >;NOGAG
03900
04000 ; PUT OUT A "TEMPXX" SYMBOL
04100
04200 MOVE A,$PNAME(LPSA) ;ID NO FOR THIS TEMP
04300 IDIVI A,=10 ;TENS IN A, ONES IN B
04400 ADDI A,1
04500 IMULI A,50 ;RADIX50 FOR TENS
04600 ADDI B,1 ;RADIX50 FOR ONES
04700 ADD A,[<XWD 100000,0>+(<RADIX50 0,TEMP>*50*50)]
04800 ADD A,B ;A HAS RADIX50 FOR "TEMPXX"
04900 NOGAG <
05000 HRRZ B,PCNT
05100 >;NOGAG
05200 GAG <
05300 HRRZ B,$ADR(LPSA);HAVE ADDR ALREADY
05400 >;GAG
05500 PUSHJ P,SCOUT ;WRITE A SYMBOL
05600
05700 NOGAG <
05800 MOVEI A,0
05900 PUSHJ P,CODOUT
06000 >;NOGAG
06100 TMNXT: HLRZ PNT,%RVARB(LPSA) ;GET NEXT ONE
06200 TLNN FF,ALLOCT
06300 JRST TMNN
06400 FREBLK ;RELEASE THE SYMBOL TABLE BLOCK
06500 TMNN: MOVE LPSA,PNT ;COPY IT BACK.
06600 JUMPN LPSA,TMPAL ;LOOP
06700 POPJ P,
06800
06900
07000 ↑LNKMAK: ; PUT OUT STRING LINK BLOCK, IF NECESSARY
07100 NOGAG <;DON'T NEED IN "GOGOL"
07200 SKIPN TEMP,SLOCALS
07300 JRST SETLNQ
07400 LSH TEMP,-1 ;NUMBER OF STRINGS
07500 HRLZ A,TEMP ;WORD WILL BE #STRINGS,,ADDR OF FIRST
07600 HRRZ LPSA,SLIMS ;SEMANTICS OF FIRST
07700 HRL C,$ADR(LPSA) ;ADDR OF FIRST
07800 TRO A,NOUSAC+USADDR
07900 PUSHJ P,EMITER ;PUT OUT DESCRIPTOR WORD
08000 EMIT (<NOADDR+NOUSAC>) ;LINKAGE WORD -- PUT OUT ZERO
08100 MOVEI B,1 ;STRING LINK.
08200 PUSHJ P,LNKOUT ;THEN A LINKAGE CALL TO LOADER REFERENCING IT
08300 SETLNQ: SKIPN A,LLOCAL
08400 POPJ P, ;NO SETS TO LINK UP EITHER.
08500 MOVNS A ;A WILL BE - # OF SETS,,ADR OF FIRST.
08600 HRRZ LPSA,LLIMS ;SEMANTICS OF FIRST ONE.
08700 HRL C,$ADR(LPSA) ;ADDRESS OF FIRST ONE.
08800 HRRI A,NOUSAC!USADDR
08900 PUSHJ P,EMITER ;PUT IT OUT.
09000 EMIT (NOADDR!NOUSAC) ;FOR THE LINK.
09100 MOVEI B,3 ;SET LINK NUMBER
09200 JRST LNKOUT
09300 >;NOGAG
09400
09500 SNTP: POPJ P,
09600
00100 COMMENT ⊗REQINI -- USER REQUIRED INITIALIZTIONS⊗
00200 ZERODATA()
00300 INIPDP: 0 ;QSTACK POINTER FOR INITIALIZATIONS
00400 INIMAN: 0 ;FLAG IF INMAIN HAS BEEN CALLED
00500 ENDDATA
00600
00700 DSCR REQINI,REQIN1,REQIN2
00800 CAL PUSHJ
00900 PARM REQINI -- TAKES PROC SEMBLK FROM GENLEF+1
01000 REQIN1 -- PROC SEMBLK IN PNT
01100 REQIN2 -- INITIALIZATION WORD IN A
01200 -- PHASE #,,LOC TO BE PUSHJ'ED TO
01300 DES PUSHES AN INITIALIZATION REQUEST ONTO QSTACK INIPDP. DONES
01400 WILL PUT OUT THE CONTENTS OF THIS QSTACK AS THE INITIALIZATION
01500 REQUEST BLOCK.
01600 ⊗
01700
01800 ↑REQINI:MOVE PNT,GENLEF+1 ;GET PROCEDURE
01900 ↑REQIN1:HLRZ PNT2,%TLINK(PNT);2ND BLOCK
02000 ;;#JH# ↓ RHT 9-29-72 TYPO ERROR
02100 HRLZI A,1 ;
02200 CAME A,$NPRMS(PNT2) ;ANY PAPAMS
02300 ERR <THIS PROCEDURE HAS PARAMETERS>,1
02400 PUSHJ P,GETAD
02500 TLNN TBITS,FORWRD!EXTRNL ;IF ONE OF THESE, HARDER
02600 JRST ESYCS
02700 HRRZ C,PCNT
02800 HRLI C,2(C)
02900 EMIT <JRST NOUSAC!USADDR> ;JRST .+2
03000 HRRZ A,PCNT
03100 HRLI A,400000
03200 QPUSH (INIPDP) ;REMEMBER THIS SPOT
03300 EMIT <JRST NOUSAC> ;CALL THE PROCEDURE
03400 POPJ P,
03500 ESYCS: HRRZ A,$ADR(PNT)
03600 HRLI A,400000
03700 REQIN2: QPUSH (INIPDP) ;REMEMBER THE ROUTINE ADDRESS
03800 POPJ P,
03900
04000
04100 COMMENT ⊗ INMAIN - REQUEST INITIALIZATION FOR MAINPR IF NOT ALREADY DONE ⊗
04200
04300 ↑INMAIN: SKIPE INIMAN ;ALREADY REQUESTED?
04400 POPJ P, ;YES
04500 SETOM INIMAN ;REQUESTED NOW
04600 HRRZ C,PCNT
04700 HRLI C,2(C) ;FOR JRST .+2
04800 EMIT <JRST NOUSAC!USADDR>
04900 HRL C,PCNT
05000 EXCH C,LIBTAB+RMAINPR ;LIBRARY ENTRY FOR MAINPR
05100 EMIT <JRST NOUSAC!USADDR>
05200 HRR A,PCNT
05300 SUBI A,1
05400 HRLI A,1 ;PHASE 1
05500 JRST REQIN2
05600 SUBTTL DONES -- Storage Allocation Routines -- end of program
05700
00100 DSCR DONES
00200 PRO DONES
00300 DES This is the DONE code. It takes care of any allocation that
00400 must be left until the end, allocates constants,etc.
00500 The order of operations is:
00600
00700 1. Allocate space for any remaining variables, temps, etc.
00800 1aa. Put out block of counters if /K switch is specified.
00900 1aaa. Put out initialization link.
01000 1a. Put out LEAP printnames if any.
01100 2. Allocate space for constants,string constants, and address constants.
01200 3. Output external requests for built-in procedures.
01300 4. Output external requests for run-time (XCALL) routines.
01400 5. Put out rqsts for other programs to be loaded, libraries
01500 to be searched
01600 6. Finish all binary output, and write an end block.
01700 7. Put out the space allocation information block. This is examined
01800 at run time to know how much space need be allocated for various
01900 purposes (strings, leap, array push-down, etc.).
02000
02100 SEE ALOT for variable-allocation code
02200 ⊗
02300
02400 ;1
02500
02600 ↑DONES: PUSHJ P,ALLSTO ;STORE EVERYONE
02700 DIS <
02800 MOVE A,[XWD 3,3]
02900 PUSHJ P,CREINT
03000 EMIT <SUB P,NOUSAC>
03100 >;DIS
03200 EMIT (<POPJ RP,NOUSAC+NOADDR>) ;RETURN
03300 TLO FF,ALLOCT ;THIS TIME WE DO THINGS RIGHT OFF
03400 PUSHJ P,ALOT
03500 SKIPE ADRTAB ;MUST BE EXHAUSTED AT THIS POINT
03600 ERR <DRYROT -- DONES>,1
03700 REN <
03800 PUSHJ P,LOSET ;DATA TO DATA SEGMENT
03900 >;REN
04000
00100
00200 COMMENT ⊗
00300 If the /K switch was specified, we are now ready to alocate
00400 space for the counters and put out the small data block used
00500 by the runtime routines K.ZERO and K.OUT. The block is linked to
00600 other such blocks via the loader LINK feature, using link
00700 number 5. There will be multiple counter blocks only in the
00800 case of multiple compilations. If there are no counters
00900 inserted, then nothing is put out. The symbolic name
01000 .KOUNT is given to the location of the first counter. The
01100 routine K.OUT needs a file name to write the counters out to
01200 after execution. The filename is set to the name of the listing
01300 file. (they will have different extensions.) The generated
01400 code will look as follows:
01500
01600 --------------------------
01700 | SIXBIT /FILNAM/ |
01800 --------------------------
01900 | LINK to other blocks |
02000 --------------------------
02100 | IOWD 4,.-2 |
02200 --------------------------
02300 | IOWD n,.KOUNT |
02400 --------------------------
02500 | 0 |
02600 --------------------------
02700 .KOUNT: | 1st counter |
02800 --------------------------
02900 | . . . |
03000
03100 | . . . |
03200 --------------------------
03300 | nth counter |
03400 --------------------------
03500
03600 ⊗
03700 SKIPE KOUNT ;ARE WE INSERTING COUNTERS
03800 SKIPN KCOUNT ;AND ARE THERE ANY
03900 JRST NOK3 ;NO ON ONE OF THE ABOVE
04000 MOVEI TBITS2,LSTCDB ;GET FILE NAME
04100 MOVE A,CFIL(TBITS2)
04200 TLZ FF,RELOC ;DON'T RELOCATE IT
04300 PUSHJ P,CODOUT ;WRITE IT
04400 MOVEI A,0
04500 PUSHJ P,CODOUT ;PUT OUT A ZERO WORD
04600 MOVEI B,5 ;LINK IT INTO CHAIN 5
04700 PUSHJ P,LNKOUT
04800 MOVE C,PCNT
04900 MOVSI C,-3(C)
05000 EMIT (<XWD -4,NOUSAC!USADDR>) ;IOWD 4,.-2
05100 MOVN A,KCOUNT
05200 HRLZ A,A ;-COUNT
05300 HRR A,PCNT ;.KOUNT-2
05400 ADDI A,1 ; IOWD N,.KOUNT
05500 TLO FF,RELOC ;RELOC PLEASE
05600 PUSHJ P,CODOUT
05700 MOVEI A,0 ;ANOTHER 0
05800 PUSHJ P,CODOUT
05900 PUSHJ P,FRBT ;FORCE OUT CODE BLOCK
06000 HRRZ B,PCNT
06100 MOVE A,[RADIX50 10,.KOUNT] ;DEFINE SYMBOLIC NAME
06200 PUSHJ P,SCOUT ;FOR THE COUNTERS
06300 MOVE A,KCOUNT
06400 ADDM A,PCNT ;LEAVE SPACE FOR THEM
06500
06600 COMMENT ⊗ Now we fix up all counters addresses in
06700 the AOS instructions that have already been output.
06800 ⊗
06900
07000 MOVE B,PCNT ;POINT JUST PAST THE COUNTERS
07100 ISK1: MOVEI B,-1(B) ;MOVE POINTER BACK ONE
07200 QPOP (KPDP) ;GET ADDR OF AN AOS
07300 JUMPL A,NOK3 ;THAT'S ALL
07400 HRL B,A ;PREPARE B FOR FBOUT
07500 PUSHJ P,FBOUT ;FIXUP
07600 JRST ISK1 ;ONE MORE TIME
07700 NOK3:
07800 ; here put the initialization requests.
07900 SKIPN INIPDP ;ANY ON THE QSTACK?
08000 JRST INI.DN ;NO
08100 MOVEI A,0 ;FOR THE LINK
08200 TLZ FF,RELOC
08300 PUSHJ P,CODOUT
08400 MOVEI B,%INLNK
08500 PUSHJ P,LNKOUT ;PUT OUT THE LINK
08600 TLO FF,RELOC
08700 QBEGIN (INIPDP) ;GET READY TO TAKE SOME OUT
08800 NX.INI: QTAKE (INIPDP) ;TAKE NEXT ENTRY
08900 JRST INI.D1 ;DONE
09000 PUSHJ P,CODOUT ;PUT OUT THE REQUEST
09100 JRST NX.INI
09200 INI.D1: MOVEI A,0
09300 TLZ FF,RELOC
09400 PUSHJ P,CODOUT
09500 INI.DN:
00100 NOGAG < ;BLOCK BITS USED BY "GOGOL", SO NO NEED
00200 IFN PATSW,<
00300 HRLI B,3 ;ADDRESS OF 1ST AOS IF IN LOW SEG
00400 REN <
00500 SKIPE HISW
00600 HRLI B,400003 ;IT'S IN HIGH SEGMENT
00700 >;REN
00800 HRR B,PCNT
00900 PUSHJ P,FBOUT ;INITIAL AOS "PAT" FIXUP
01000 HRLI C,-1 ;BLOCK ALWAYS ACTIVE
01100 EMIT (<USADDR+NORLC+NOUSAC>) ;SO PUT OUT LARGE COUNT
01200 >;PATSW
01300 REN <
01400 PUSHJ P,HISET ;BACK TO UPPER SEGMENT TO
01500 >;REN
01600 PUSHJ P,LNKMAK ;MAKE LINKAGE BLOCK
01700 >;NOGAG
01800
01900 ;1A
02000 NOGAG <
02100 LEP <
02200 SKIPE LEAPIS ;ANY LEAP ASKED FOR
02300 HRROS ITEMNO ;TELL RUNTIMS YES
02400 SKIPN ITMSTK ;ANY DECLARED ITEMS?
02500 JRST CONQN ;NONE
02600 MOVE A,PCNT ;GET PROG. CNTR
02700 MOVEM A,TINIT ;SAVE IT
02800 MOVE A,ITMCNT ;NUMBER OF DECLARED ITEMS(INCLUDES GLOBALS)
02900 TLZ FF,RELOC
03000 PUSHJ P,CODOUT ;PUT IT OUT
03100 MOVE B,ITMBEG ;START OF ITEM QSTACK
03200 LPITMT: QTAKE (ITMSTK) ;GET ITEM,TYPE
03300 JRST PNMOUT ;THROUGH, NO MORE ITEMS
03400 PUSHJ P,CODOUT
03500 JRST LPITMT ;LOOP
03600
03700 PNMOUT:
03800 MOVE A,PCNT
03900 MOVEM A,PINIT
04000 TLZ FF,RELOC
04100 SOS A,PNMSW ;NUMBER OF NAMES.
04200 PUSHJ P,CODOUT ;PUT OUT SOME STUFF.
04300 SKIPN PNMSW
04400 JRST CONQN ;NO PNAMES -- SE ABOUT CONSTANTS.
04500 MOVE B,PNBEG ;THE QTAKE POINTER
04600 ITM1: QTAKE (PNLST)
04700 JRST ITM2 ;ALL DONE.
04800 MOVE PNT,A ;FOR EMITTER
04900 HRRI A,NOUSAC
05000 PUSHJ P,EMITER ; #CHARS,,POINTER TO BYTE POINTER.
05100 JRST ITM1
05200 ITM2:
05300 >;LEP
05400 >;NOGAG
05500 CONQN:
05600
05700
00100
00200 ;2
00300 TLZ FF,RELOC
00400 HRRZ LPSA,CONINT ;VARB-LIKE RING OF CONSTANTS.
00500 JUMPE LPSA,STRGO
00600 REN <
00700 MOVSI D,RECURS ;GET REAL LIVE CONSTANTS FIRST
00800 PUSHJ P,INTLOP
00900 PUSHJ P,LOSET ;SWITCH TO LOWER SEGMENT IF HISW
01000 HRRZ LPSA,CONINT ;NOW GET CONSTANTS WHICH WERE
01100 JUMPE LPSA,STRG1 ; (IF ANY LEFT)
01200 MOVEI D,0 ;UNIQUELY CREATED AS REFERENCE
01300 PUSH P,INTRET ; PARAMS
01400 ; PUSHJ P,INTLOP
01500 >;REN
01600 INTLOP:
01700 REN <
01800 TDNE D,$TBITS(LPSA) ;THIS TIME?
01900 JRST GOLEFT ; NO, WAIT FOR LOWER SEGMENT
02000 >;REN
02100 HRLZ B,$ADR(LPSA) ;FIXUP
02200 JUMPE B,NOINT ;NOT USED
02300 HRR B,PCNT
02400 PUSHJ P,FBOUT
02500 MOVE A,$VAL(LPSA) ;VALUE
02600 PUSHJ P,CODOUT ;A WORD FOR IT.
02700 NOINT:
02800 REN <
02900 PUSHJ P,URGCNM ;REMOVE FROM RING
03000 GOLEFT:
03100 >;REN
03200 LEFT ,%RVARB,INTRET
03300 JRST INTLOP ;LOOP UNTIL DONE.
03400 INTRET:
03500 REN <
03600 POPJ P,.+1
03700 STRG1: PUSHJ P,HISET ;BACK TO UPPER
03800 >;REN
03900
04000 STRGO: HRRZ LPSA,CONSTR ;STRING CONSTANT RING.
04100 JUMPE LPSA,BILGO
04200 STRLOP:
04300 NOGAG <;PRELOADS WILL NEED SPECIAL ATTENTION HERE IN "GOGOL"
04400 MOVS B,$ADR(LPSA) ;FIXUPS
04500 JUMPE B,[SKIPN B,$VAL(LPSA) ;SEE IF STORED IN PRE-LOADED ARRAY
04600 JRST NOSTR ;NOT USED AT ALL.
04700 HRR B,PCNT ;NOW XWD FIXUP,,PCNT
04800 PUSHJ P,FBOUT ;EMIT IT.
04900 JRST PUTIT]
05000 HRLZ B,$ADR(LPSA) ;FIXUP FOR FIRST WORD.
05100 JUMPE B,.+3
05200 HRR B,PCNT
05300 PUSHJ P,FBOUT
05400 HRRZ A,$PNAME(LPSA) ;COUNT OF CHARACTERS.
05500 PUSHJ P,CODOUT
05600 HLLZ B,$ADR(LPSA) ;FIXUP FOR SECOND WORD.
05700 JUMPE B,.+3
05800 HRR B,PCNT
05900 PUSHJ P,FBOUT ;OUTPUT THE FIXUP.
06000 JUMPE A,NOSTR ;IN CASE NULL FLIES BY.
06100 HRLI A,(<POINT 7,0>) ;BYTE POINTER
06200 HRR A,PCNT
06300 ADDI A,1 ;POINT TO .+1
06400 SKIPN B,$VAL(LPSA) ;FIXUP FROM PRE-LOADED ARRAY IF ANY.
06500 JRST .+3
06600 HRR B,A ;THE PCNT FOR ASCII
06700 PUSHJ P,FBOUT ;GO GUYS.
06800 TLO FF,RELOC
06900 PUSHJ P,CODOUT
07000 TLZ FF,RELOC
07100 PUTIT: HRRZ B,$PNAME(LPSA) ;COUNT AGAIN.
07200 ADDI B,4
07300 IDIVI B,5 ;B HAS NUMBER OF WORDS.
07400 HRRZ C,$PNAME+1(LPSA) ;POINTER TO FIRST WORD.
07500 STLL: MOVE A,(C)
07600 PUSHJ P,CODOUT
07700 AOS C
07800 SOJG B,STLL
07900 >;NOGAG
08000 NOSTR:
08100 LEFT ,%RVARB,BILGO
08200 JRST STRLOP ;LOOP FOR ALL STRINGS.
08300
08400
00100
00200 ;3
00300
00400 BILGO:
00500 NOGAG < ;WILL GET ADDRESSES DIRECTLY FROM SYMBOL TABLE IN "GOGOL"
00600 MOVE LPSA,VARB
00700 CAIE LPSA,RESYM ;IT SHOULD BE HERE
00800 ERR <DRYROT -- DONES>
00900 BILOP: HRRZ B,$ADR(LPSA) ;FIXUP
01000 JUMPE B,BILR
01100 TLNE FF,CREFSW ;CREFFING??
01200 PUSHJ P,CREFDEF ;DEFINE THIS SYMBOL.
01300 PUSHJ P,SOUT ;GENERATE EXTERNAL REQUEST
01400 BILR: LEFT ,%RVARB,LIBGO
01500 JRST BILOP ;LOOP UNTIL DONE
01600
01700 ;4
01800 ; IF GAG, WILL GET ADDRESSES DIRECTLY (MOVEI)
01900
02000 LIBGO: MOVEI C,0
02100 LIBLOP: SKIPN B,LIBTAB(C) ;FIXUP FOR THIS FCN.
02200 JRST NONT
02300 YESLIB: MOVSS B
02400 MOVE A,LIBNAM(C) ;RADIX50 FOR THIS FCN.
02500 PUSHJ P,SCOUT ;GENERATE THE REQUEST.
02600 NONT: AOS C
02700 CAIE C,LIBNUM
02800 JRST LIBLOP ;LOOP UNTIL DONE.
02900
03000 ;5
03100
03200 HRROI TEMP,SALIB+1 ;FAKE STRING DESCRIPTOR FOR SAIL LIBRARY
03300 REN <
03400 SKIPE HISW ;WANT RE-ENTRANT LIBRARY?
03500 HRROI TEMP,SALIBH+1 ;YES
03600 >;REN
03700 POP TEMP,PNAME+1
03800 POP TEMP,PNAME
03900 MOVEI B,LBTAB ;PUT OUT LIBRARY SEARCH
04000 PUSHJ P,PRGOUT ; REQUEST
04100
04200 ;6
04300
04400 PUSHJ P,FRBT ;FORCE BINARY.
04500
04600 MOVEI B,FXTAB
04700 PUSHJ P,GBOUT ;AND FIXUPS.
04800
04900 MOVEI B,SMTAB
05000 PUSHJ P,GBOUT ;AND SYMBOLS.
05100
05200 MOVEI B,PRGTAB
05300 PUSHJ P,GBOUT ;AND PROGRAM/LIBRARY REQUESTS
05400
05500 MOVEI B,LBTAB
05600 PUSHJ P,GBOUT
05700
05800 ;7
05900 ;NOW OUTPUT THE SPACE ALLOCATION BLOCK.
06000
06100 MOVE A,PCNT
06200 MOVEM A,SPCPC ;PCNT FOR SPACE BLOCK.
06300 MOVEM A,SLNKWD ;AND FOR LINK WORD.
06400 HRRZ TEMP,SPCTBL ;NUMBER OF WORDS OF DATA
06500 ADDI A,(TEMP) ;NUMBER OF WORDS IN OBJECT MODULE
06600 MOVEM A,PCNT
06700 MOVEI B,SPCTBL ;SPACE TABLE
06800 AOS TEMP,SPCTBL ;ONE MORE (A ZERO)
06900 MOVEI A,=18
07000 CAIG A,(TEMP)
07100 HRRM A,SPCTBL ;MAKE SURE NO OVERFLOW HAPPENS
07200 PUSHJ P,GBOUT
07300
07400 MOVEI TEMP,2 ;SPACE BLOCK IS TYPE 2
07500 MOVEM TEMP,LNKNM
07600 MOVE B,SDSCRP ;LINK BLOCK
07700 PUSHJ P,GBOUT ;AND LINK (LINK NUMBER 2)
07800
07900
08000 MOVE B,EBDSC ;ASSUME SHOULD WRITE START ADDR, ETC.
08100 TLNN FF,MAINPG ;A STARTING ADDRESS?
08200 MOVE B,EBDSC1 ;NO, NO START ADDR, NO INIT CODE FIXUPS
08300 REN <
08400 PUSHJ P,HISET ;BE SURE PCNT IS IN UPPER SEGMENT
08500 MOVE A,[XWD 5,2] ;ASSUME TWOSEG END BLOCK
08600 MOVE TEMP,[IORM A,STRDDR] ;PUT CONSTANT SYMS INTO HI SEG
08700 SKIPE HISW ;RIGHT?
08800 JRST TSEND ;RIGHT
08900 MOVE TEMP,[ANDCAM A,STRDDR] ;PUT CONSTANT SYMS INTO LOW SEG
09000 MOVE A,[XWD 5,1] ;ONESEG END BLOCK
09100 SUB B,[XWD 1,0] ;ONE FEWER WORDS TO WRITE
09200 TSEND: MOVEM A,PRGBRK-2 ;TO CODE WORD OF LOADER BLOCK
09300 MOVEI A,400000 ;SEGMENT CONTROL BIT
09400 XCT TEMP ;STARTING ADDRESS INTO RIGHT SGMNT
09500 HRRI TEMP,CONSYM+1 ;NOW
09600 XCT TEMP ; PUT S., RPGSW, SAILOR REQUESTS
09700 ADDI TEMP,2 ; INTO PROPER SEGMENT (SEE TOTAL,
09800 XCT TEMP ; UNDER LOADER OUTPUT BLOCKS
09900 ADDI TEMP,4 ; -- END BLOCKS SECTION
10000 XCT TEMP
10100 MOVE A,HCNT ;YES, GET CODE COUNT
10200 MOVEM A,PRGBRK+1 ;LOW SEG BREAK IF TWO SEGMENTS
10300 >;REN
10400 MOVE A,PCNT ;ONLY OR HIGH SEG BREAK
10500 MOVEM A,PRGBRK
10600 PUSHJ P,GBOUT ;WRITE THE END BLOCKS.
10700
10800 >;NOGAG
10900 ;TEMP ****** FOR TESTING SLS
11000 SLS <
11100 GEN
11200 SALCAL (SLSTST,<LINKS>,<PNAME>)
11300 >;SLS
11400 POPJ P, ;ALL DONES
00100 COMMENT ⊗MEMORY and LOCATION EXECS, ALSO UINCLL⊗
00200 ↑↑ZBITS: SETZM BITS
00300 POPJ P,
00400 ↑↑MEMI: SKIPA TBITS,[INTEGR]
00500 ↑↑MEMS: MOVE TBITS,BITS
00600 TDNE TBITS,[XWD PROCED!SBSCRP,STRING];ILLEGAL TYPES
00700 ERR <ILLEGAL DATA TYPE FOR MEMORY>,1
00800 PUSHJ P,TYPDEC ;GET PARSE TOKEN
00900 MOVEM A,PARRIG ;PUT IT AWAY
01000 MOVE PNT,GENLEF+1 ;THE EXPRESSION GUY
01100 MOVE SBITS,$SBITS(PNT) ;SEMANTICS OF THE EXPRN
01200 HRRZ TEMP,$TBITS(PNT) ;IT BETTER BE INTEGER
01300 ;;#JY# RHT (11-2-72) ↓ TURN OFF SHORT
01400 TRZ TEMP,SHORT ;TTURN OFF SHORT
01500 TLNN SBITS,NEGAT ;AND NOT NEGATIVE
01600 CAIE TEMP,INTEGR
01700 JRST COERCI
01800 TLNE SBITS,INAC ;LOADED?
01900 JRST ITSINA ;YES
02000 TLNE SBITS,ARTEMP ;IF NOT A TEMP
02100 TLNE SBITS,INDXED ;OR INDEXED TEMP
02200 JRST LODIT ;THEN LOAD IT
02300 TLO SBITS,INDXED ;MAKE INDEXED TEMP
02400 MOVEM SBITS,$SBITS(PNT) ;
02500 MOVEM TBITS,$TBITS(PNT) ;
02600 SETZM $VAL(PNT) ;
02700 POPJ P,
02800 LODIT: PUSHJ P,GETAN0 ;GET AN AC
02900 EMIT <HRRZ> ;LOAD IT
03000 MAKTMP: HRLZI SBITS,PTRAC!INDXED
03100 PUSHJ P,GETTEM
03200 HRRZM LPSA,ACKTAB(D) ;REMEMBER IT
03300 HRRM D,$ACNO(LPSA)
03400 MOVEM LPSA,GENRIG
03500 POPJ P,
03600 ITSINA: HRRZ D,$ACNO(PNT) ;GET AC #
03700 PUSHJ P,REMOPA ;IF TEMP, REMOP IT
03800 ;;#JV# ↓ (10-20-72) RHT CANNOT USE AC0
03900 JUMPE D,LODIT ;
04000 TLZ SBITS,INAC ;
04100 MOVEM SBITS,$SBITS(PNT) ;THIS WONT BE INAC ANY MORE
04200 JRST MAKTMP ;NICE, NEW TEMP
04300 COERCI: PUSH P,TBITS ;
04400 MOVEI B,INTEGR
04500 GENMOV (GET,POSIT!INSIST!GETD)
04600 PUSHJ P,REMOP ;DONE OLD THING
04700 POP P,TBITS
04800 JRST MAKTMP ;NEW TEMP
04900
05000
05100 ↑↑LOCN: MOVE PNT,GENLEF+1 ;
05200 PUSHJ P,GETAD
05300 TLNN SBITS,PTRAC ;IF PTRAC THEN LEAVE ALONE
05400 PUSHJ P,INCOR ;GET THE THING TO CORE
05500 GENMOV (GET,ADDR) ;ADDRESS OF THIS
05600 PUSHJ P,REMOP
05700 MOVEI TBITS,INTEGR
05800 HRLZI SBITS,INAC
05900 GENMOV (MARK,0)
06000 MOVEM PNT,GENRIG
06100 PUSHJ P,TYPDEC
06200 MOVEM A,PARRIG
06300 POPJ P,
06400
06500 ↑UINCLL: PUSHJ P,ALLSTO ;FLUSH ACS
06600 XCALL (.UINITS) ;EMIT CALL TO USER INITIALIZATIONS
06700 POPJ P,
06800
00100 DSCR MAKBUK, FREBUK
00200 CAL PUSHJ
00300 PAR current value of SYMTAB
00400 DES MAKBUK allocates a new Semblk, copies current Symtab
00500 bucket list into it; saves a pointer to the old one --
00600 see main SAIL data descriptions for details. This is
00700 how scope is handled, because...
00800 FREBUK deletes this Semblk, restores old pointer. It is
00900 up to somebody else (ALOT) to delete all the local Semblks
01000 which are no longer available via SYMTAB
01100 This junk is unnecessary for STRCON and CONST buckets, since
01200 all such entities are global (one bucket list)
01300 SEE main SAIL data definitions in SAIL
01400 SEE BLOCK, UP1, UP2, etc.
01500 ⊗
01600 ↑MAKBUK:
01700 GETBLK ;MAKE A NEW BLOCK
01800 EXCH LPSA,SYMTAB ;SYMTAB IS NOW UPDATED
01900 HRLI PNT,(LPSA)
02000 HRR PNT,SYMTAB ;PREPARE TO BLT
02100 HRRZM LPSA,BLKLEN-1(PNT) ;TIE TO OLD ONE
02200 MOVE TEMP,PNT
02300 BLT PNT,BLKLEN-2(TEMP) ;COPY BUCKET
02400 POPJ P,
02500
02600
02700 ↑FREBUK:
02800 MOVE LPSA,SYMTAB
02900 HRRZ A,BLKLEN-1(LPSA) ;TIE
03000 MOVEM A,SYMTAB
03100 FREBLK ;RELEASE THE BLOCK
03200 POPJ P,
03300
03400
03500 BEND GENDEC
03600 SUBTTL ERROR MESSAGE EXECS
03700
00100 BEGIN ERRORS
00200
00300 ;THE FIRST ROUTINE ALWAYS PRINTS OUT A NEAT MESSAGE....
00400
00500 DEFINE XX (NAME,MESSG,CODE) <
00600 ↑ NAME : ERR. 1,[ASCIZ/MESSG/]
00700 TLNN FF,ERSEEN
00800 POPJ P,
00900 SKIPE CODE
01000 POPJ P, ;IF CODE=0, THEN WE RECOVERED SAFELY
01100 TLO FF,ERSEEN
01200 TLZ FF,BINARY
01300 TERPRI <IRRECOVERABLE ERROR.NO REL FILE WILL BE PRODUCED.>
01400 ;******STUFF TO CLOSE THE FILE????
01500 >
01600
01700 XX (ER1,<START YOUR PROGRAM WITH BEGIN OR ENTRY - WILL SCAN FOR BEGIN.>,1)
01800 XX (ER2,<BAD ENTRY STATEMENT - WILL SCAN FOR BEGIN.>,1)
01900 XX (ER3,<YOU SEEM TO HAVE USED A , INSTEAD OF A ; BETWEEN DECLARATIONS.>,0)
02000 XX (ER4,<BOGUS IDENTIFIER IN IDENTIFIER LIST.>,1)
02100 XX (ER5,<INSERTING FORGOTTEN SEMI-COLON.>,0)
02200 XX (ER6,<DELETED EXTRA SEMI-COLON.>,0)
02300 XX (ER7,<SYNTAX ERROR. CURRENT STATEMENT OR DECLARATION WILL BE FLUSHED.>,2)
02400 XX (ER8,<SYNTAX ERROR AT END OF EXPRESSION - WILL CHECK FOR PARENTHESES MISMATCH.>,0)
02500 XX (ER15,<ARRAYS SUBSCRIPTING USES BRACKETS! PARENTHESIS REPLACED.>,0)
02600 XX (ER24,<YOU CAN NOT BEGIN A DECLARATION OR STATEMENT LIKE THIS.>,1)
02700 XX (ER33,<NEED AN "UNTIL" AFTER THE STATEMENT OF A "DO ...UNTIL ...">,1)
02800 XX (ER34,<BAD BLOCKING - TOO FEW ENDS.>,1)
02900 XX (ER35,<UNDECLARED ARRAY>,0)
03000 XX (ER36,<MISSING ( INSERTED.>,0)
03100 XX (ER37,<EXTRA ) DELETED.>,0)
03200 XX (ER38,<REQUIRE A BOOLEAN OR AN ALGEBRAIC EXPRESSION HERE.>,1)
03300 XX (ER39,<REQUIRE A CONSTANT ALGEBRAIC EXPRESSION HERE.>,1)
03400 XX (ER40,<INSERTED MISSING ).>,0)
03500 XX (ER41,<YOU CANNOT BEGIN AN EXPRESSION LIKE THIS.>,1)
03600 XX (ER48,<MISSING RIGHT CURLY BRACKET INSERTED.>,0)
03700 XX (ER59,<NEED AN ASSOCIATIVE EXPRESSION HERE.>,1)
03800 XX (ER66,<USE A BEGIN OR A ( AFTER A CASE.>,1)
03900 XX (ER68,<YOU FORGOT TO INCLUDE THE CONTEXT.>,1)
04000 XX (ERTRAP,<QTRAP: ACCORDING TO THE PRODUCTIONS, ITS IMPOSSIBLE FOR TO HIT THIS. SEE A SAIL HACKER>,1);
04100
04200
04300 DEFINE YY (NAME,MESSG) <
04400 ↑NAME: TERPRI <MESSG>
04500 POPJ P,
04600 >
04700 YY (ERR101,<STATEMENT FLUSHED.>)
04800 YY (ERR102,<BLOCK FOUND WHILE FLUSHING STATEMENT - WILL TRY TO PARSE IT.>)
04900 YY (ERR103,<EXTRA ) DELETED.>)
05000 YY (ERR104,<MISSING ) INSERTED.>)
05100 YY (ERR105,<BLOCK END OKAY - FLUSH OF STATEMENT CONTINUES.>)
05200 YY (ERR106,<MISSING ; INSERTED.>)
05300 YY (ERR107,<SORRY - CAN'T CONTINUE.>)
05400 YY (ERR108,<DISREGARD THE ABOVE AND REMEMBER TO USE BRACKETS ON ARRAYS.>)
05500 YY (ERR109,<CVMS TAKES AS AN ARGUMENT A MACRO NAME - PARAMETERS ARE IGNORED>)
05600 YY (ERR110,<DECLARATION TAKES AN IDENTIFIER AS AN ARGUMENT - FLUSH REST OF STATEMENT>)
05700 YY (ERR111,<CHECK_TYPE ONLY TAKES VALID DECLARATIONS OR PARTS OF DECALRATIONS AS ARGUMENTS - FLUSH REST OF STATEMENT>)
05800
05900
06000 XX (ERR112,<BIND USED INCORRECTLY, WILL BE IGNORED>)
06100 XX (ERR113,<PROPS REQUIRES SINGLE ITEM EXPR AS ARGUMENT>)
06200 XX (ERR114,<PROPS MAY BE ASSIGNED ONLY ARITHMETIC VALUES>)
06300 XX (ERR115,<MISSING ARRAY BOUND-PAIR LIST>)
06400
06500
00100 DSCR SCNBAK,POPBAK,KILPOP,QREM2,QTYPCK;
00200 PRO SCNBAK,POPBAK,KILPOP,QREM1,QREM2,QTYPCK;
00300 DES Error recovery execs:
00400 SCNBAK: backs scanner up by one token.
00500 POPBAK: returns you to the previous production.
00600 KILPOP: returns the production control stack (stack for the ↑EX and ↓↓ stuff)
00700 to its pristine state.
00800 QREM1,QREM2: Called at the end of a block to delete untyped identifiers still left
00900 on the VARB ring.
01000 QTYPCK: Called from PRE in TOTAL. Every time one GENMOVs with CONVRT on, QTYPCK
01100 checks to see if the type bits of either the source or destination are zero in the
01200 rh, and gives the untyped one the type of the other. If the source is undeclared,
01300 then QTYPCK corrects the source, and if the source is a temp, it corrects the
01400 procedure or array that generated the temp.
01500 ⊗
01600
01700
01800 ;BACKS THE SCANNER UP BY ONE TOKEN
01900 ↑SCNBAK: MOVE A,PARLEF
02000 MOVEM A,SAVPAR
02100 MOVE A,GENLEF
02200 MOVEM A,SAVSEM
02300 TLO FF,BAKSCN ;SCANNER IS AHEAD.
02400 POPJ P,
02500
02600 ;RETURNS YOU TO THE PREVIOUS PRODUCTION
02700 ↑POPBAK: MOVE A,SAVPOP
02800 MOVEM A,-2(P) ;PRODUCTION POINTER.
02900 POPJ P,
03000
03100 ;FLUSHS THE PRODUCTION CONTROL STOCK (used for the ↑EX, ↓↓ stuff)
03200 ↑KILPOP:
03300 MOVE TEMP,PCSAV ; GET PRODUCTION CONTROL STACK POINTER
03400 KPJ: SKIPGE -1(TEMP) ; IS THIS THE JUMP TO PARSE
03500 JRST KILDUN ; YES, LEAVE IT AND GO HOME
03600 POP TEMP,-1(TEMP) ; NO, GO DOWN ONE
03700 JRST KPJ
03800 KILDUN: MOVEM TEMP,PCSAV
03900 POPJ P,
04000
04100
04200 ;CALLED AT THE END OF A BLOCK TO DELETE THE UNTYPED IDENTIFIERS(EXCEPT PROCEDURES)
04300 ↑QREM1: SKIPA LPSA,GENLEF+1 ; GET THE BLOCK
04400 ↑QREM2: MOVE LPSA,GENLEF+2
04500 JUMPE LPSA,QFIN ; THIS BEGIN HASN'T A BLOCK SEMBLK
04600 QL: HRRZ LPSA,%RVARB(LPSA) ; GO RIGHT ON VARB RING...
04700 QL1: JUMPE LPSA,QFIN ; UNTIL YOU GET TO THE END.
04800 HRRZ TBITS,$TBITS(LPSA) ; THE TYPE...
04900 JUMPN TBITS,QL ; IS OKAY...
05000 TRNE TBITS,PROCED ; DON'T KILL IT IF IT'S A PRODEDURE
05100 JRST QL
05200 HRRZ TBITS,%RVARB(LPSA) ;SAVE THE NEXT GUY..........
05300 PUSHJ P,DESTRO ; KILL THE BASTARD!
05400 MOVE LPSA,TBITS
05500 JRST QL1
05600 QFIN: POPJ P,
05700
05800 ;DESTROYS AN IDENTIFIER - REMOVES FROM VARB RING - NULLIFIES HASH AND STR RING
05900 ↑QDESID:
06000 MOVE LPSA,GENLEF+1 ; GET THE FATED IDENTIFIER
06100 DESTRO: PUSHJ P, URGVRB ; UNRING IT
06200 SETZM ,$PNAME(LPSA) ; CHANGE ITS NAME TO SOMETHING ABSURD
06300 SETZM $PNAME+1(LPSA)
06400 POPJ P, ; AND RETURN
06500
06600
06700 ;CALLED FROM PRE OF GENMOV - CHANGES UNTYPED TO A REASONABLE TYPE
06800 ↑QTYPCK:
06900 TRNN TBITS,-1 ; IS THE SOURCE OF UNDECLARED TYPE
07000 JRST QMATCH ; YES, GO GIVE IT THE DESTINATIONS TYPE
07100 TRNE B,-1 ; IS THE DESTINATION UNTYPED
07200 POPJ P, ; NO, GO HOME
07300 HRR B,TBITS ; YES, GIVE IT THE SOURCE TYPE
07400 POPJ P,
07500
07600 QMATCH:
07700 HLR TBITS,$SBITS(PNT) ; GET SOURCE SEMANTICES
07800 HRRM B,$TBITS(PNT) ; GIVE THE SOURCE THE DESTINATION TYPE
07900 TLNN TBITS,INAC!ARTEMP!INUSE ; IS IT A TEMP
08000 JRST .+3 ; NO, GO BACK
08100 HLR TBITS,%TLINK(PNT) ; GET THE ARRAY OR PROCEDURE
08200 HRRM B,$TBITS(TBITS) ; GIVE IT THE GOOD TYPE
08300 HRR TBITS,B ; GIVE TBITS THE GOOD TYPE
08400 POPJ P,
08500
08600
00100 DSCR UNDEC -- Undeclared identifiers;
00200 PRO UNDEC;
00300 DES Declares an identifier globally or locally and modifies symbol table nicely.
00400 When the token I is scanned at the identifier switch areas S1 and EX1 in
00500 HEL, we call UNDEC. Since TYPDEC (called by the scanner) returns I if there are
00600 no type bits on, we may have merely an untyped identifier, so we don't need to
00700 declare it again. Otherwise, we create an empty semblk, then link it on the
00800 appropriate varb ring, hash bucket and string ring for global or local declaration.
00900 We make the assumption that the user has declared something in the global block,
01000 and thus use the block semblk referenced by QQBLK which is loaded at the first
01100 call of the exec BLOCK.
01200 ⊗
01300
01400 ;ENTERS IDENTIFIER ON LOCAL OR GLOBAL LEVEL
01500 ↑UNDEC: SKIPE A,GENLEF ; IF THE THING IS DECLARED...
01600 POPJ P, ; THEN GO BACK ELSE...
01700 PRINT <UNDECLARED IDENTIFIER: >
01800 HRRI A,PNAME ; STUFF TO PRINT THE PNAME OF THE ID
01900 HRRZ B,(A)
02000 MOVE A,1(A)
02100 JRST QPRSL1
02200 QPRSL: ILDB C,A
02300 TTCALL 1,C
02400 QPRSL1: SOJGE B,QPRSL
02500 ERR < >,1 ; PRINT REST OF ERROR MESS
02600
02700 TERPRI <DO YOU WANT THIS DECLARED IN THE OUTER-MOST BLOCK?>
02800 PRINT <(TYPE Y OR N)→ >
02900 TTCALL 0,B ; GET HIS RESPONSE
03000 TERPRI ; CRLF
03100 CAIL B,"a" ; LOWER CASE?
03200 SUBI B,40 ; CONVERT TO UPPER
03300 CAIN B,"N" ; NO?
03400 JRST LOCA ; WHAT A CHICKEN!
03500 CAIE B,"Y"
03600 JRST .-8 ; PLEASE TYPE Y OR N...
03700 JRST GLOBA ; DECLARE IT GLOBALY
03800 LOCA: SKIPN QQBLK ; IF HE HASN'T DECLARED ANYTHING
03900 TERPRI <YOUR PROGRAM WILL END FUNNY -- NEXT TIME DECLARE YOUR IDENTIFIERS>
04000 HRRZI A,INTEGR ; SOMETHING SIMPLE TO DECLARE
04100 MOVEM A,BITS
04200 PUSHJ P,ENTERS ; GO MAKE IT
04300 MOVE A,NEWSYM ; GET IT BACK
04400 MOVEM A,GENRIG ; PUT IT OUT
04500 POPJ P, ; RETURN
04600
04700 GLOBA: SKIPN PNT,QQBLK ; GET THE HIGHEST BLOCK WITH DECLARATION
04800 JRST LOCA ; WE ARE THE HIGHEST BLOCK
04900 GETBLK NEWSYM ; GET A NEW SEMBLK
05000 MOVE LPSA,NEWSYM
05100 HRROI PNT2,PNAME+1 ; PDP FOR NAME
05200 POP PNT2,$PNAME+1(LPSA)
05300 POP PNT2,$PNAME(LPSA)
05400 PUSHJ P,RNGSTR ; PUT IT ON THE STRING RING
05500 HRRZ PNT,%RVARB(PNT) ; THE FIRST MEMBER OF BLOCK'S VARB RING
05600 HRRZ PNT2,$SBITS(PNT) ; GET THE LEVELS,ZERO THE SBITS
05700 MOVEM PNT2,$SBITS(LPSA)
05800 HRLM LPSA,%RVARB(PNT) ; LPSA ← 1ST
05900 HRRM PNT,%RVARB(LPSA) ; LPSA → 1ST
06000 MOVE PNT,QQBLK ; GET THE HIGHEST BLOCK
06100 HRRM LPSA,%RVARB(PNT) ; BLK → LPSA
06200 HRLM PNT,%RVARB(LPSA) ; BLK ← LPSA
06300
06400 MOVE PNT,HPNT ; GET HASH(BUCK(QQBLK)) INTO B
06500 SUB PNT,SYMTAB ; CORRECT ADDRESS TO...
06600 MOVE C,PNT ; GENERALIZED HPNT FOR LATTER
06700 MOVE PNT2,QQBLK
06800 HRRZ PNT2,%TBUCK(PNT2)
06900 ADD PNT,PNT2 ; ... TO THE OUTER LEVEL
07000 XCT PNT
07100 HRRZ B,LPSA ; B = HASH(BUCK(QQBLK))
07200 HRRZ A,SYMTAB ; INITIALIZE
07300
07400 ;GO UP THE BLOCKS, FIXING THE HASH BUCKETS OR HASH CHAINGS THAT USED TO PT TO B
07500 HASHL: MOVE PNT,C ; GET GENERAL HPNT
07600 ADD PNT,A ; CORRECT HPNT TO THIS LEVEL
07700 XCT PNT ; LPSA → HEAD OF HASH CHAIN THIS BUCKET
07800 HRRZ PNT2,LPSA
07900 CAMN B,PNT2 ; DOES B = HASH(BUCK(A)) ?
08000 JRST BUCIT ; YES,GO FIX THIS BUCKET
08100 SKIPN QQFLAG ; NO, FIX THE CHAIN.
08200 JRST UPBUCK ; WE ALREADY FIXED THE CHAIN,GO UP A BLOCK
08300
08400 SETZM QQFLAG ; MAKE SURE WE ONLY DO THIS ONCE
08500 UPCHAI: MOVE PNT,PNT2 ; FIND THE TOP GUY OF THE CHAIN BEFORE QQBLK LEVEL
08600 HRRZ PNT2,%TBUCK(PNT2) ; GO UP
08700 CAME B,PNT2 ; ARE WE AT QQBLK LEVEL YET?
08800 JRST UPCHAI ; NO, GO UP THE CHAIN
08900 HRRZ PNT2,NEWSYM ; GET THE GUY
09000 HRRM PNT2,%TBUCK(PNT) ; TOP-NOT-ON-QQBLK-GUY → UNDECLARED-GUY
09100 HRRM B,%TBUCK(PNT2) ; UNDECLARED-GUY → 1ST-OF-QQBLK-LEVEL-GUY
09200 JRST UPBUCK ; FINE, GO UP A BUCKET
09300
09400
09500 BUCIT: MOVE PNT2,NEWSYM ; WE ARE GOING TO FIX THE BUCKET BY
09600 HRRM LPSA,%TBUCK(PNT2) ; DOING A REGULAR HASH
09700 HRR LPSA,PNT2
09800 TLO PNT,2000
09900 XCT PNT
10000 JRST UPBUCK ; GO UP A BUCKET
10100
10200 UPBUCK: MOVE PNT,QQBLK ; GET THE TOP BUCKET
10300 HRRZ PNT,%TBUCK(PNT)
10400 CAMN A,PNT ; ARE WE AT THE TOP
10500 JRST .+3 ; YES, GO HOME
10600 HRRZ A,BLKLEN-1(A) ; NO, GO UP A BUCKET
10700 JRST HASHL ; NO TRY AGAIN
10800 MOVE PNT,NEWSYM ; PUT OUT, RESTORE, AND QUIT
10900 MOVEM PNT,GENRIG
11000 SETOM QQFLAG
11100 POPJ P,
11200
11300 ZERODATA( DEFAULT DECLARATIONS)
11400 ↑↑QQFLAG:0
11500 ↑↑QQBLK: 0
11600 ENDDATA
00100 DSCR QDEC0,1,2 QARSUB QARDEC QPARM QPRDEC;
00200 PRO QDEC0,QDEC1,QDEC2,QSUBSC,QARDEC,QPARM,QPRDEC.
00300 DES These execs finish the declaration of an undeclared identifier by giving
00400 it a type and appropriate goodies. The QDEC execs determine the type from the token
00500 put in PARRIG by the productions. If we need an array, we count the dimensions with
00600 QSUBSC, install them and put out a temp in QARDEC. If we need a procedure, we get a
00700 second semblk in QDEC, ring on formals in QPARM, install parmeter counts in QPRDEC,
00800 and jrst to QARDEC to generate a temp (we assume all procedures are integer
00900 functions).
01000 ⊗
01100
01200
01300 ;EXECS TO SET THE TBITS FROM THE PARSE TOKEN
01400 ↑QDEC2: MOVEI A,0 ; RIGHT - TOP
01500 JRST .+4
01600 ↑QDEC0: SKIPA A,[0] ; RIGHT - ONE DOWN
01700 ↑QDEC1: SKIPA A,[1] ; RIGHT - ONE DOWN
01800 SKIPA B,[0] ; LEFT - TOP
01900 MOVEI B,1 ; LEFT - ONE DOWN
02000 HRRZ PNT, PARRIG(A) ; GET IT
02100 MOVEI TBITS,0
02200 CAMN PNT, %ILB ; LABEL
02300 JRST [TRO TBITS,LABEL+FORWRD
02400 TERPRI <UNDECLARED IDENTIFIER DECLARED A LABEL>
02500 JRST .+15]
02600 CAMN PNT, %ISV ; SET
02700 JRST [TRO TBITS,SET
02800 TERPRI <UNDECLARED IDENTIFIER DECLARED A SET>
02900 JRST .+13]
03000 CAMN PNT,%ARID ; AN ARRAY
03100 JRST [TLO TBITS, SBSCRP!SAFE
03200 TERPRI <UNDECLARED IDENTIFIER DECLARED AN ARRAY>
03300 JRST .+11]
03400 CAMN PNT,%PCALL ; A PROCEDURE
03500 JRST .+4
03600 CAMN PNT,%S ; ANOTHER PROCEDURE
03700 JRST .+2
03800 CAMN PNT,%FCALL ; YET ANOTHER PROCEDURE
03900 JRST [MOVE TBITS, [XWD EXTRNL,PROCED!INTEGR]
04000 TERPRI <UNDECLARED IDENTIFIER DECLARED A INTEGER PROCEDURE>
04100 JRST .+3]
04200 CAMN PNT,%ITV ; ITEMVAR
04300 JRST [TRO TBITS, ITMVAR!INTEGR
04400 TERPRI <UNDECLARED IDENTIFIER DECLARED AN INTEGER ITEMVAR>
04500 JRST .+1]
04600 ; IVB GETS NO BITS
04700 CAME PNT,%S ; DONT TURN ON THE CLASIDX IF S
04800 HRLI PNT,CLSIDX ; ALL VARIABLES ARE CLASS MEMBERS
04900 MOVEM PNT,PARRIG(A) ; PUT IT OUT
05000 MOVE PNT,GENLEF(B) ; GET THE UNDECLARED GUY (from UNDEC)
05100 TLNE TBITS, SBSCRP ; IS IT AN ARRAY
05200 SETZM ,DIMNO ; YES, ZERO THE NUMBER OF DIMENSIONS
05300 TRNE TBITS,PROCED ; IF ITS A PROCEDURE...
05400 JRST [GETBLK ; GET A 2D BLOCK
05500 HRLM LPSA,%TLINK(PNT) ; PUT A PNTR TO IT IN TLINK OF PROC
05600 MOVEW %%VARB,VARB ; SAVE THE CURRENT VARB
05700 SETZM VARB ; INITIALIZE A NEW VARB
05800 JRST .+1]
05900 MOVEM TBITS,$TBITS(PNT) ; GIVE IT ITS TYPE
06000 MOVEM PNT,GENRIG(A)
06100 POPJ P,
06200
06300 %%VARB:0
06400
06500 ↑QSUBSC:
06600 AOS ,DIMNO ; COUNT DIMENSIONS
06700 MOVE PNT, GENLEF +1 ; THE EXPRESSION TEMP ..
06800 PUSHJ P,REMOP ; GETS REMOVED
06900 POPJ P,
07000 DIMNO: 0
07100
07200 ↑QARDEC:
07300 MOVE PNT2,GENLEF+2 ;GET THE ARRAY (OR PROCEDURE)
07400 MOVE PNT,DIMNO ; GET #OF DIMENSIONS
07500 HRLM PNT,$ACNO(PNT2) ; RECORD IT
07600 MOVEI TBITS,0 ; TYPE IT
07700 MOVEI D,1 ; DUMMY AC NUMBER FOR ...
07800 PUSHJ P,MARKME ; CREATING A TEMP.
07900 HRL PNT,PNT2 ; →ARR (OR →PROC) IN %TLINK( the temp)
08000 MOVEM PNT,GENRIG ; PUT IT OUT
08100 POPJ P,
08200
08300
08400
08500
08600
08700 ↑QPARM: MOVE PNT,GENLEF+2 ; GET THE PROCEDURE
08800 HLRZ PNT2,%TLINK(PNT) ; THE SECOND BLOCK
08900 PUSH P,PNT2 ; SAVE IT
09000 MOVE LPSA,GENLEF+1 ; GET THE EXPRESSION
09100 HRRZ TBITS,$TBITS(LPSA) ; GET ITS TYPE
09200 TLO TBITS,VALUE ; MAKE ALL PARAMETERS VALUE...
09300 TRNE TBITS,PROCED ; EXCEPT PROCEDURE EXPRESSIONS
09400 TLC TBITS,VALUE!REFRNC
09500 MOVEM TBITS,BITS
09600 TRNE TBITS,STRING ; IF IT IS A STRING
09700 AOS ,$NPRMS(PNT2) ; INCREMENT STRING PARM COUNT
09800 HLRZ TEMP,$NPRMS(PNT2) ; ALWAYS INCREMENT ARITH PARM COUNT
09900 AOJ TEMP,
10000 HRLM TEMP,$NPRMS(PNT2)
10100 GETBLK ; MAKE A FORMAL
10200 MOVEM TBITS,$TBITS(LPSA) ; GIVE IT A TYPE
10300 PUSHJ P,RNGVRB ; PUT IT ON THE VARB RING
10400 POP P,PNT2 ; GET 2ND BLOCK BACK
10500 SKIPN %TLINK(PNT2) ; IS THIS THE FIRST FORMAL
10600 HRLM LPSA,%TLINK(PNT2) ; YES, PUT A POINTER TO IT IN
10700 ; 2D BLOCK OF THE PROCEDURE
10800 MOVE PNT,GENLEF +1 ; GET THE EXPRESSION AND....
10900 JRST REMOP ; KILL IT!!!!! , THEN RETURN QUIETLY
11000
11100
11200 ↑QPRDEC:
11300 MOVE PNT,GENLEF+2 ;GET THE PROCEDURE
11400 HLRZ PNT2,%TLINK(PNT) ; GET THE 2D BLOCK
11500 HLRZ TEMP,$NPRMS(PNT2) ; INCREMENT ARITH PARM COUNT
11600 AOJ TEMP,
11700 HRLM TEMP,$NPRMS(PNT2)
11800 HRRZ TEMP,$NPRMS(PNT2) ; STRING PARM COUNT * 2
11900 LSH TEMP,1
12000 HRRM TEMP,$NPRMS(PNT2)
12100 MOVEW VARB,%%VARB ; RESTORE CURRENT VARB
12200 JRST QARDEC ; ASSUME FUNCTION (i.e. make a temp)
12300
12400
12500
12600
12700
12800 BEND
12900 SUBTTL EXECS to handle string constants as comments
13000
00100 BEGIN SCOMM
00200
00300 DSCR SCOMM
00400 PRO SCOMM
00500 DES Remove the damage done by using a string constant
00600 as a comment preceding a statement
00700 ⊗
00800
00900 COMMENT ⊗
01000 last prod at S1:
01100 STC → EXEC SCOMM SCAN ¬S1 #Q6
01200 ⊗
01300
01400 ↑SCOMM: GETSEM (0) ;SEMANTICS OF CONSTANT
01500 TRNN TBITS,STRING ;MUST BE A STRING CONSTANT
01600 JRST [ERR <I THOUGHT IT WAS A STRING COMMENT>,1
01700 POPJ P,]
01800
01900 ;;#FL# 11-14-71 DCS (1-1)
02000 SKIPN $VAL(PNT) ;HAS ANYONE USED THIS IN A PRELOAD?
02100 SKIPE $ADR(PNT) ;OR HAS ANYONE USED THIS AS A STRING CONSTANT?
02200 ;;#FL#
02300 JRST REMOP ; YES, NO MORE ACTION NECESSARY
02400 MOVE LPSA,PNT
02500 PUSHJ P,URGSTR ;REMOVE FROM BOTH RINGS
02600 PUSHJ P,URGCST
02700 MOVE B,HSPNT ;GET POINTER DOWN BUCKET LIST
02800 XCT B ; (SEE HASH, ENTER)
02900 HRRZS PNT
03000 MOVEI PNT2,LPSA ;MUST PRESERVE LPSA CORRECTLY IN CASE
03100 ; FIRST BLOCK IS DELETED.
03200 SCOMLP: HRRZ TEMP,(PNT2) ;TEMP← LPSA FIRST TIME, →OTHER BLOCKS LATER
03300 JUMPE TEMP,ERRSTC ;ERROR -- SHOULD FIND IT SOMEWHERE!
03400 CAMN TEMP,PNT ;IS THIS THE ONE WE WANT TO REMOVE?
03500 JRST SFNDIT ; YES
03600 MOVE PNT2,TEMP ;NO, CONTINUE
03700 JRST SCOMLP
03800
03900 SFNDIT: HRRZ TEMP,(TEMP) ;GET POINTER FROM BLOCK TO GO
04000 HRRM TEMP,(PNT2) ;AND RELINK
04100 TLO B,2000 ;PUT BUCKET POINTER BACK IN CASE
04200 XCT B ;IT CHANGED
04300 FREBLK (PNT) ;REMOVE THE BLOCK
04400 POPJ P,
04500
04600 ERRSTC: ERR <DRYROT AT SCOMM>,1
04700
04800 BEND SCOMM
04900 SUBTTL START_CODE (inline) EXECS
05000
00100 BEGIN INLINE
00200
00300 ZERODATA (START_CODE VARIABLES)
00400
00500 ↓CODSEM: 0 ;SEMANTICS OF ADDRESS FIELD (IF VBL)
00600
00700 ↓CODVAL: 0 ;VALUE OF ADDRESS, AC, INDEX FIELDS (CONST STUFF)
00800
00900 ↓INSTBL: 0 ;→SIXBIT TABLE OF OPCODES, IF HAS BEEN READ IN
01000
01100 ↓OPCOD: 0 ;OPCODE OF INSTRUCTION BEING ASSEMBLED
01200
01300 ;OPDUN -- on if opcode field has been scanned. Also used as flag
01400 ; to EMITER that the instruction going out is a START_CODE
01500 ; produced intruction -- avoids optimizations of various forms
01600 ↑OPDUN: 0
01700
01800 DATA (START_CODE VARIABLES)
01900
02000 ; THIS IS THE ENTER BLOCK FOR THE SIXBIT OPCODE TABLE USED TO
02100 ; ALLOW SYMBOLIC OPCODES IN START_CODE INSTRUCTIONS
02200
02300 TNAME: OPNAME
02400 'OPS '
02500 TWORD3: 0
02600 TPPN: OPPPN
02700 ENDDATA
02800
00100 DSCR CODNIT, WRDNIT, ONEWRD, SETSIX, SETOP, CODIND, CODREG, etc.
00200 PRO CODNIT WRDNIT ONEWRD SETSIX SETOP CODIND CODREG CODLIT ERRCOL ERRCOM
00300 DES These routines handle the START_CODE/QUICK_CODE syntax.
00400 The only surprise is a table of SIXBIT opcodes which are read in
00500 when needed. No variable with the same name as one of these opcodes
00600 may be used within a CODE block.
00700 ⊗
00800
00900 ↑CODNIT:
01000 JRST .+1(B) ;START_CODE CLEARS, QUICK_CODE DOESN'T
01100 PUSHJ P,ALLSTO ;CLEAR THE WORLD
01200 ; JRST WRDNIT ;FALL THROUGH
01300
01400 ↑WRDNIT:
01500 SETZM OPCOD ;OP, AC, INDEX, INDR COLLECTED HERE
01600 SETZM OPDUN
01700 SETZM CODVAL ;OPDUN IS A FLAG, CODVAL IF CONST
01800 SETZM CODSEM ;SEMANTICS OF ADDR IF NON-CONST
01900 ;;#JU# RHT (DEL 1 LINE) -- DONT HURT ACKTAB 10-23-72
02000 MOVSI TEMP,INLIN ;SET SPECIAL SCANNER BIT SO THAT
02100 ORM TEMP,SCNWRD ; @ IS TREATED AS A DELIM,
02200 ; (DCS -- 8/13/70) PNAME+1 ZEROED
02300 NOCODE: POPJ P,
02400
02500 ↑ONEWRD:
02600 SKIPE A,OPCOD
02700 HRRZS CODVAL
02800 OR A,CODVAL
02900 HRL C,A
03000 HLLZS A ;PUT OP CODE,UNRELOC ADDR IN PLACE
03100 SKIPN OPDUN ;WAS ANYTHING SEEN?
03200 JRST NOCODE ; NO, NULL STATEMENT
03300 SETOM OPDUN ;TELL EMITER DOING INLINE CODE
03400 TRO A,NOUSAC!USADDR!NORLC ;ASSUME CONSTANT ADDR FIELD
03500 SKIPN PNT,CODSEM ;WELL, WHICH IS IT?
03600 JRST EMITER ;EMIT IT
03700 MOVE TBITS,$TBITS(PNT) ;GET BITS FOR FXTWO SET
03800 TRC A,USADDR!NORLC!FXTWO ;ASSUME A STRING
03900 ;; #JRL# 9-19-72 A STRING ITEMVAR IS NOT A STRING
04000 TDNN TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;IF SBSCRP ∨ ¬STRING,
04100 ;; #JRL#
04200 TRNN TBITS,STRING ; REVERSE ASSUMPTION
04300 TRZ A,FXTWO
04400 JRST EMITER ;GO EMIT CODE
04500
04600 ↑SETSIX:
04700 MOVEI A,0 ;COLLECT SIXBIT
04800 HRRZ TEMP,PNAME ;LENGTH
04900 JUMPE TEMP,.+2 ;IGNORE NULL STRINGS
05000 CAILE TEMP,6 ;MUST BE OPCODE-SIZED
05100 POPJ P, ; NO PRINT NAME, NO SIXBIT
05200 MOVE C,[POINT 6,A]
05300 MOVE LPSA,PNAME+1 ;BYTE POINTER TO STRING
05400 LOOP: SOJL TEMP,LOKSIX ;GOT IT CONVERTED, LOOK IT UP
05500 ILDB D,LPSA ;GET CHAR
05600 SUBI D,40
05700 IDPB D,C ;COLLECT SIXBIT
05800 JRST LOOP
05900
06000 LOKSIX:
06100 Comment ⊗ might be an OPCOD -- will assume it is if it is in
06200 the opcode table. To find out, we may have to read said
06300 table in. Then we will do a linear search to discover
06400 the correct instruction code ⊗
06500
06600 SKIPE B,INSTBL ;TABLE IN CORE?
06700 JRST TABLIN ;YES, ADDRESS IN B
06800 ;;#GN# DCS 2-6-72 (1-1) INCLUDE UUO'S, STANFORD UUO'S
06900 EXPO <
07000 SIZZZZ←←700-40
07100 >;EXPO
07200 NOEXPO <
07300 SIZZZZ←←724-40
07400 >;NOEXPO
07500 MOVEI C,SIZZZZ+4 ;SIZE OF TABLE, PLUS BREATHING ROOM
07600 ;; #GN#
07700 PUSHJ P,CORGET ;GET SOME SPACE FOR IT
07800 ERR <DRYROT -- INLINE CODE>
07900 IFN 0,< ;DELETED BY SPROULL AT PARC!!!
08000 SUBI B,1
08100 HRLI B,-SIZZZZ ;IOWD -SIZE,ADDR-1 FOR OP TABLE
08200 MOVEM B,INSTBL ;STORE ITS ADDRESS
08300 MOVEI B+1,0 ;END COMMAND LIST
08400 SETZM TWORD3
08500 MOVE TEMP,[OPPPN]
08600 MOVEM TEMP,TPPN ;RESTORE OPCODE FILE PPN
08700 OPEN 17,[17
08800 OPDEV
08900 0]
09000 ERR <DRYROT -- INLINE CODE>
09100 LOOKUP 17,TNAME
09200 ERR <DRYROT -- INLINE CODE>
09300 INPUT 17,B ;READ THE OP TABLE
09400 RELEASE 17,
09500 >;END OF DELETED
09600 IFN 1,< ;TENEX STUFF TO GET THE INLINE FILE.
09602 OPDEF JSYS [104000000000]
09700
09800 PUSH P,A ;SAVE SIXBIT
09900 PUSH P,B ;SAVE CORE ADDRESS
10000 SUBI B,1
10100 HRLI B,-SIZZZZ
10200 MOVEM B,INSTBL ;POINTER TO TABLE.
10300 MOVSI 1,100001
10400 HRROI 2,[ASCIZ /<SAIL>2OPS2.OPS/]
10500 JSYS 20 ;GET A JFN
10600 ERR <DRYROT -- INLINE CODE>
10700 MOVE 2,[XWD 440000,200000]
10800 JSYS 21 ;OPENF
10900 ERR <DRYROT -- INLINE CODE>
11000 MOVNI 3,SIZZZZ
11100 POP P,2
11200 HRLI 2,444400 ;36 BIT BYTES
11300 JSYS 52 ;SIN
11400 JSYS 22 ;CLOSF
11500 ERR <DRYROT -- INLINE CODE>
11600 POP P,A ;SAVED ACCUMULATOR.
11650 MOVE B,INSTBL ;GET POINTER TO TABLE.
11700 > ;TENEX ADDITIONS
11800
11900 TABLIN:
12000
12100 Comment ⊗
12200 B → current table entry (LH IS -COUNT)
12300 A will soon be sixbit for OPcode being sought
12400 ⊗
12500
12600
12700 MOVE D,[CAME A,(B)] ;SET UP QUICK SEARCH LOOP
12800 MOVE D+1,[AOBJN B,D] ;ITERATION CONTROL
12900 MOVE D+2,[JRST TSTFND] ;OUT OF ACS
13000 AOJA B,D ;INITIAL ADD
13100
13200 TSTFND: JUMPGE B,UNFNDOP ;SEARCH EXHAUSTED
13300
13400 FNDOPC: SUB B,INSTBL ;GET OP CODE IN OCTAL
13500 ;; #GN#
13600 ADDI B,37 ;ADJUST -- FIRST 40 NOT LOADED
13700 ;;#GN# (1-1)
13800 IFE IMSSS,<
13900 MOVEM B,GENRIG ;STORE FOR A WHILE
14000 >;
14100 IFN IMSSS,<
14200 LSH B,=27 ;MOVE OVER TO OPCODE FIELD
14300 MOVEM B,GENRIG ;AND STORE
14400 >;IFN IMSSS
14500 MOVE TEMP,%OPC ;MARK OPCODE FOUND
14600 MOVEM TEMP,PARRIG ;SAVE FOR PARSER
14700 IFE IMSSS,<
14800 UNFNDOP:
14900 >;
15000 IFN IMSSS,<
15100 POPJ P,
15200 UNFNDOP:
15300
15400 COMMENT !
15500 HERE WE LOOK THROUGH A TABLE OF JSYS'S IN FILE
15600 JSYSES. THREE VALUES ARE GIVEN THERE:
15700 JSTBL: THE START OF THE TABLE OF SIXBIT NAMES
15800 JSNO: THE NUMBER OF THE CORRESPONDING JSYS
15900 JTBLSZ: THE SIZE OF THE TABLE
16000 !
16100
16200 MOVSI B,-JTBLSZ
16300 MOVE D,[CAME A,JSTBL(B)] ;FOR COMPARISON -- AOBJN ALREADY
16400 ;THERE
16500 MOVE D+2,[JRST TSTJSY]
16600 JRST D ;JUMP INTO ACS
16700 TSTJSY: JUMPGE B,NOJSYS ;SEARCH EXHAUSTED
16800 MOVE B,JSNO(B) ;THE NUMBER OF THIS JSYS
16900 MOVEM B,GENRIG
17000 MOVE TEMP,%OPC ;MARK AS FOUND
17100 MOVEM TEMP,PARRIG ;SAVE FOR PARSER
17200 NOJSYS:
17300 >;IFN IMSSS
17400
17500 POPJ P,
17600
00100
00200 ↑CODID: SKIPN PNT,GENLEF+1 ;MUST BE DEFINED
00300 ERR <UNDEFINED INSTRUCTION ELEMENT>,1,FRGET
00400 MOVNI TBITS2,1 ;ASSUME NO OPCODE SEEN YET
00500 HLLOS TEMP,OPDUN ;MARK SOMETHING SEEN
00600 JUMPG TEMP,MAYBOP ;NO OPCODE SEEN, MIGHT BE CNST OPCODE
00700 NONOPC: SKIPN CODSEM ;CHECK TWO ADDRESS FIELDS
00800 SKIPE CODVAL
00900 ERR <TWO ADDRESS FIELDS>,1
01000 MOVEI TBITS2,0 ;OPCODE SEEN PREVIOUSLY
01100 MAYBOP: SETOM OPDUN ;NO MORE OPCODES ALLOWED
01200 PUSHJ P,GETAD
01300 TLNN TBITS,CNST ;CONSTANT?
01400 JRST CODVBL ; NO, MUST BE VARIABLE ADDR FIELD
01500 GENMOV (CONV,INSIST,INTEGR) ;GET INTEGER CONSTANT
01600 MOVE A,$VAL(PNT)
01700 JUMPL TBITS2,STROPC ;OPCODE CONSTANT (ASSUME SO, ANYWAY)
01800 MOVEM A,CODVAL ;NOT OPCODE, SAVE HERE
01900 JRST REMOP ;DON'T NEED CONST ANY MORE
02000 STROPC: ORM A,OPCOD ;NON-DESTRUCTIVE STORE
02100 JRST REMOP ;DON'T NEED SEMANTICS
02200
02300 CODVBL: TLNN SBITS,FIXARR ;ACCEPT CNST-CNST-CNST ARRAY
02400 TLNN SBITS,ARTEMP!STTEMP ; AND VARIABLES
02500 JRST VBLOK
02600 ERR <EXPRESSION NOT LEGAL AS INSTRUCTION ADDRESS>,1
02700 VBLOK: MOVEM PNT,CODSEM ;SAVE SEMANTICS
02800 POPJ P,
02900
03000
03100 ↑SETOP: HLLOS TEMP,OPDUN ;SET SOMETHING SEEN
03200 JUMPL TEMP,TWOOP ;TWO OPCODES
03300 SETOM OPDUN ;MARK OPCODE DONE
03400 MOVE A,GENLEF
03500 IFE IMSSS,<
03600 DPB A,[POINT 9,OPCOD,8] ;OPCOD POSITION
03700 >;IFE IMSSS
03800 IFN IMSSS,<
03900 MOVEM A,OPCOD ;ASSUMING IN OPCODE-FIELD SET UP
04000 >;
04100 POPJ P,
04200 TWOOP: ERR <TWO OPCODES>,1,FRGET
04300
04400 ↑CODIND:
04500 HLLOS OPDUN ;MARK SOMETHING SEEN
04600 MOVSI TEMP,20 ;INDIRECT BIT
04700 ORM TEMP,OPCOD ;PUT IN OPCOD WORD
04800 FRGET: POPJ P,
04900
05000 ↑CODREG:
05100 HLLOS OPDUN
05200 SKIPN PNT,GENLEF+1 ;MUST BE A CONSTANT
05300 ERR <NON-CONSTANT AC FIELD>,1,REMOP
05400 GENMOV (CONV,GETD!INSIST,INTEGR)
05500 TLNN TBITS,CNST ;MUST BE A CONSTANT
05600 ERR <NON-CONSTANT AC FIELD>,1,REMOP
05700 MOVE TEMP,$VAL(PNT) ;GET ITS VALUE
05800 DPB TEMP,[POINT 4,OPCOD,12] ;DEPOSIT IN AC FIELD
05900 JRST REMOP
06000
06100 ↑CODX: HLLOS OPDUN
06200 SKIPN PNT,GENLEF+1 ;MUST BE A CONSTANT
06300 ERR <NON-CONSTANT INDEX FIELD>,1,REMOP
06400 GENMOV (CONV,GETD!INSIST,INTEGR)
06500 TLNN TBITS,CNST
06600 ERR <NON-CONSTANT INDEX FIELD>,1,REMOP
06700 MOVE TEMP,$VAL(PNT)
06800 DPB TEMP,[POINT 4,OPCOD,17] ;INDEX FIELD
06900 JRST REMOP
07000
07100 ↑CODLIT:
07200 HLLOS OPDUN
07300 SKIPN PNT,GENLEF+1
07400 ERR <NON-CONSTANT LITERAL>,1,REMOP
07500 MOVE TBITS,$TBITS(PNT)
07600 TLNN TBITS,CNST
07700 ERR <NON-CONSTANT LITERAL>,1,REMOP
07800 SKIPN CODVAL ;CHECK FOR TWO ADDRESS FIELDS
07900 SKIPE CODSEM
08000 ERR <TWO ADDRESS FIELDS>,1,REMOP
08100 CODBK: MOVEM PNT,CODSEM
08200 MOVSI TEMP,INLIN ;TURN SPECIAL SCANNING BIT
08300 ORM TEMP,SCNWRD ;BACK ON
08400 POPJ P,
08500
08600 ↑LITOFF: ;TURN OFF SPECIAL @ SCANNING BIT IN SCNWRD
08700 ; (CALLED WHEN SCANNING LITERALS, AND WHEN LEAVING A
08800 ; START_CODE BLOCK)
08900 MOVSI TEMP,INLIN
09000 ANDCAM TEMP,SCNWRD
09100 POPJ P,
09200
09300
09400 ↑ERRCOL:
09500 ERR <UNDEFINED LABEL OR BAD SYNTAX>,1
09600 POPJ P,
09700
09800 ↑ERRCOM:
09900 ERR <COMMA USED IN WRONG MANNER>,1
10000 POPJ P,
10100
10200 BEND INLINE
10300 SUBTTL COUNTER SYSTEM EXECS
10400
00100 BEGIN COUNT
00200
00300 DSCR KOUNT1,KOUNT2,KOUNT3,KOUNT4,KOUNT5 -- INSERT A COUNTER
00400 PRO KOUNT1 KOUNT2 KOUNT3 KOUNT4 KOUNT5
00500 DES These exec routines insert a counter into the code and a
00600 marker into the output listing. They are NO-OP's unless the
00700 /K switch is specified. As a listing file is necessary for /K,
00800 it is not necessary to check SCANWD for listing. KOUNT2 will
00900 someday do the right thing for multiple labels. KOUNT3 , KOUNT4,
01000 and KOUNT5 insert a different marker for counters in expressions.
01100 The multiplicity of routines for expression counters comes from
01200 the necessity of having the counter immediately after the reserved
01300 word in order for the analysis routine to work right.
01400 ⊗
01500 ↑KOUNT6: SKIPA C,[","] ;SHOULD FOLLOW ","
01600 ↑KOUNT5: MOVEI C,"(" ;SHOULD FOLLOW "("
01700 JRST KOUNT4+1
01800 ↑KOUNT3: SKIPA C,["N"] ;SHOULD FOLLOW "THEN"
01900 ↑KOUNT4: MOVEI C,"E" ;SHOULD FOLLOW "ELSE"
02000 MOVEI B,3 ;MARKER IS BETA (β)
02100 MOVEI D,LSTOU1 ;USE THIS LIST ROUTINE
02200 JRST KOUNT1+2
02300 ↑KOUNT2: ;EVENTUALLY, CHECK FOR MULTIPLE LABELS
02400 ↑KOUNT1: MOVEI B,2 ;MARKER IS ALPHA (α)
02500 MOVEI D,LSTOUT ;USE THIS ROUTINE
02600 SKIPN KOUNT ;ARE WE INSERTING COUNTERS
02700 POPJ P, ;NO
02800 MOVE A,[AOS 0]
02900 PUSHJ P,CODOUT ;PUT THE ADD INSTR INTO THE CODE
03000 AOS KCOUNT ;COUNT THE COUNTERS
03100 MOVE A,PCNT
03200 SUBI A,1
03300 QPUSH (KPDP,) ;SAVE ADDRESS OF AOS
03400 MOVEI A,177 ;PUT A MARKER INTO
03500 PUSHJ P,(D) ; THE LIST FILE
03600 MOVEI C,177 ;NEEDED IN CASE WE'RE CALLING LSTOU1
03700 MOVE A,B ;GET THE CHARACTER FOR THE MARK
03800 PUSHJ P,(D)
03900 POPJ P,
04000
04100 BEND COUNT
04200
04300 SUBTTL ARRAY DECLARATION AND INDEXING EXECS
04400
04500
04600
00100